Theory Miscellaneous
section ‹Miscellaneous Lemmata›
theory Miscellaneous
imports Main "HOL-Library.Sublist" "HOL-Library.While_Combinator"
begin
subsection ‹List: zip, filter, map›
lemma zip_arg_subterm_split:
assumes "(x,y) ∈ set (zip xs ys)"
obtains xs' xs'' ys' ys'' where "xs = xs'@x#xs''" "ys = ys'@y#ys''" "length xs' = length ys'"
proof -
from assms have "∃zs zs' vs vs'. xs = zs@x#zs' ∧ ys = vs@y#vs' ∧ length zs = length vs"
proof (induction ys arbitrary: xs)
case (Cons y' ys' xs)
then obtain x' xs' where x': "xs = x'#xs'"
by (metis empty_iff list.exhaust list.set(1) set_zip_leftD)
show ?case
by (cases "(x, y) ∈ set (zip xs' ys')",
metis ‹xs = x'#xs'› Cons.IH[of xs'] Cons_eq_appendI list.size(4),
use Cons.prems x' in fastforce)
qed simp
thus ?thesis using that by blast
qed
lemma zip_arg_index:
assumes "(x,y) ∈ set (zip xs ys)"
obtains i where "xs ! i = x" "ys ! i = y" "i < length xs" "i < length ys"
proof -
obtain xs1 xs2 ys1 ys2 where "xs = xs1@x#xs2" "ys = ys1@y#ys2" "length xs1 = length ys1"
using zip_arg_subterm_split[OF assms] by moura
thus ?thesis using nth_append_length[of xs1 x xs2] nth_append_length[of ys1 y ys2] that by simp
qed
lemma filter_nth: "i < length (filter P xs) ⟹ P (filter P xs ! i)"
using nth_mem by force
lemma list_all_filter_eq: "list_all P xs ⟹ filter P xs = xs"
by (metis list_all_iff filter_True)
lemma list_all_filter_nil:
assumes "list_all P xs"
and "⋀x. P x ⟹ ¬Q x"
shows "filter Q xs = []"
using assms by (induct xs) simp_all
lemma list_all_concat: "list_all (list_all f) P ⟷ list_all f (concat P)"
by (induct P) auto
lemma map_upt_index_eq:
assumes "j < length xs"
shows "(map (λi. xs ! is i) [0..<length xs]) ! j = xs ! is j"
using assms by (simp add: map_nth)
lemma map_snd_list_insert_distrib:
assumes "∀(i,p) ∈ insert x (set xs). ∀(i',p') ∈ insert x (set xs). p = p' ⟶ i = i'"
shows "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)"
using assms
proof (induction xs rule: List.rev_induct)
case (snoc y xs)
hence IH: "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)" by fastforce
obtain iy py where y: "y = (iy,py)" by (metis surj_pair)
obtain ix px where x: "x = (ix,px)" by (metis surj_pair)
have "(ix,px) ∈ insert x (set (y#xs))" "(iy,py) ∈ insert x (set (y#xs))" using y x by auto
hence *: "iy = ix" when "py = px" using that snoc.prems by auto
show ?case
proof (cases "px = py")
case True
hence "y = x" using * y x by auto
thus ?thesis using IH by simp
next
case False
hence "y ≠ x" using y x by simp
have "List.insert x (xs@[y]) = (List.insert x xs)@[y]"
proof -
have 1: "insert y (set xs) = set (xs@[y])" by simp
have 2: "x ∉ insert y (set xs) ∨ x ∈ set xs" using ‹y ≠ x› by blast
show ?thesis using 1 2 by (metis (no_types) List.insert_def append_Cons insertCI)
qed
thus ?thesis using IH y x False by (auto simp add: List.insert_def)
qed
qed simp
lemma map_append_inv: "map f xs = ys@zs ⟹ ∃vs ws. xs = vs@ws ∧ map f vs = ys ∧ map f ws = zs"
proof (induction xs arbitrary: ys zs)
case (Cons x xs')
note prems = Cons.prems
note IH = Cons.IH
show ?case
proof (cases ys)
case (Cons y ys')
then obtain vs' ws where *: "xs' = vs'@ws" "map f vs' = ys'" "map f ws = zs"
using prems IH[of ys' zs] by auto
hence "x#xs' = (x#vs')@ws" "map f (x#vs') = y#ys'" using Cons prems by force+
thus ?thesis by (metis Cons *(3))
qed (use prems in simp)
qed simp
subsection ‹List: subsequences›
lemma subseqs_set_subset:
assumes "ys ∈ set (subseqs xs)"
shows "set ys ⊆ set xs"
using assms subseqs_powset[of xs] by auto
lemma subset_sublist_exists:
"ys ⊆ set xs ⟹ ∃zs. set zs = ys ∧ zs ∈ set (subseqs xs)"
proof (induction xs arbitrary: ys)
case Cons thus ?case by (metis (no_types, lifting) Pow_iff imageE subseqs_powset)
qed simp
lemma map_subseqs: "map (map f) (subseqs xs) = subseqs (map f xs)"
proof (induct xs)
case (Cons x xs)
have "map (Cons (f x)) (map (map f) (subseqs xs)) = map (map f) (map (Cons x) (subseqs xs))"
by (induct "subseqs xs") auto
thus ?case by (simp add: Let_def Cons)
qed simp
lemma subseqs_Cons:
assumes "ys ∈ set (subseqs xs)"
shows "ys ∈ set (subseqs (x#xs))"
by (metis assms Un_iff set_append subseqs.simps(2))
lemma subseqs_subset:
assumes "ys ∈ set (subseqs xs)"
shows "set ys ⊆ set xs"
using assms by (metis Pow_iff image_eqI subseqs_powset)
subsection ‹List: prefixes, suffixes›
lemma suffix_Cons': "suffix [x] (y#ys) ⟹ suffix [x] ys ∨ (y = x ∧ ys = [])"
using suffix_Cons[of "[x]"] by auto
lemma prefix_Cons': "prefix (x#xs) (x#ys) ⟹ prefix xs ys"
by simp
lemma prefix_map: "prefix xs (map f ys) ⟹ ∃zs. prefix zs ys ∧ map f zs = xs"
using map_append_inv unfolding prefix_def by fast
lemma length_prefix_ex:
assumes "n ≤ length xs"
shows "∃ys zs. xs = ys@zs ∧ length ys = n"
using assms
proof (induction n)
case (Suc n)
then obtain ys zs where IH: "xs = ys@zs" "length ys = n" by moura
hence "length zs > 0" using Suc.prems(1) by auto
then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
hence "length (ys@[v]) = Suc n" using IH(2) by simp
thus ?case using IH(1) v by (metis append.assoc append_Cons append_Nil)
qed simp
lemma length_prefix_ex':
assumes "n < length xs"
shows "∃ys zs. xs = ys@xs ! n#zs ∧ length ys = n"
proof -
obtain ys zs where xs: "xs = ys@zs" "length ys = n" using assms length_prefix_ex[of n xs] by moura
hence "length zs > 0" using assms by auto
then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
hence "(ys@zs) ! n = v" using xs by auto
thus ?thesis using v xs by auto
qed
lemma length_prefix_ex2:
assumes "i < length xs" "j < length xs" "i < j"
shows "∃ys zs vs. xs = ys@xs ! i#zs@xs ! j#vs ∧ length ys = i ∧ length zs = j - i - 1"
by (smt assms length_prefix_ex' nth_append append.assoc append.simps(2) add_diff_cancel_left'
diff_Suc_1 length_Cons length_append)
subsection ‹List: products›
lemma product_lists_Cons:
"x#xs ∈ set (product_lists (y#ys)) ⟷ (xs ∈ set (product_lists ys) ∧ x ∈ set y)"
by auto
lemma product_lists_in_set_nth:
assumes "xs ∈ set (product_lists ys)"
shows "∀i<length ys. xs ! i ∈ set (ys ! i)"
proof -
have 0: "length ys = length xs" using assms(1) by (simp add: in_set_product_lists_length)
thus ?thesis using assms
proof (induction ys arbitrary: xs)
case (Cons y ys)
obtain x xs' where xs: "xs = x#xs'" using Cons.prems(1) by (metis length_Suc_conv)
hence "xs' ∈ set (product_lists ys) ⟹ ∀i<length ys. xs' ! i ∈ set (ys ! i)"
"length ys = length xs'" "x#xs' ∈ set (product_lists (y#ys))"
using Cons by simp_all
thus ?case using xs product_lists_Cons[of x xs' y ys] by (simp add: nth_Cons')
qed simp
qed
lemma product_lists_in_set_nth':
assumes "∀i<length xs. ys ! i ∈ set (xs ! i)"
and "length xs = length ys"
shows "ys ∈ set (product_lists xs)"
using assms
proof (induction xs arbitrary: ys)
case (Cons x xs)
obtain y ys' where ys: "ys = y#ys'" using Cons.prems(2) by (metis length_Suc_conv)
hence "ys' ∈ set (product_lists xs)" "y ∈ set x" "length xs = length ys'"
using Cons by fastforce+
thus ?case using ys product_lists_Cons[of y ys' x xs] by (simp add: nth_Cons')
qed simp
subsection ‹Other Lemmata›
lemma inv_set_fset: "finite M ⟹ set (inv set M) = M"
unfolding inv_def by (metis (mono_tags) finite_list someI_ex)
lemma lfp_eqI':
assumes "mono f"
and "f C = C"
and "∀X ∈ Pow C. f X = X ⟶ X = C"
shows "lfp f = C"
by (metis PowI assms lfp_lowerbound lfp_unfold subset_refl)
lemma lfp_while':
fixes f::"'a set ⇒ 'a set" and M::"'a set"
defines "N ≡ while (λA. f A ≠ A) f {}"
assumes f_mono: "mono f"
and N_finite: "finite N"
and N_supset: "f N ⊆ N"
shows "lfp f = N"
proof -
have *: "f X ⊆ N" when "X ⊆ N" for X using N_supset monoD[OF f_mono that] by blast
show ?thesis
using lfp_while[OF f_mono * N_finite]
by (simp add: N_def)
qed
lemma lfp_while'':
fixes f::"'a set ⇒ 'a set" and M::"'a set"
defines "N ≡ while (λA. f A ≠ A) f {}"
assumes f_mono: "mono f"
and lfp_finite: "finite (lfp f)"
shows "lfp f = N"
proof -
have *: "f X ⊆ lfp f" when "X ⊆ lfp f" for X
using lfp_fixpoint[OF f_mono] monoD[OF f_mono that]
by blast
show ?thesis
using lfp_while[OF f_mono * lfp_finite]
by (simp add: N_def)
qed
lemma preordered_finite_set_has_maxima:
assumes "finite A" "A ≠ {}"
shows "∃a::'a::{preorder} ∈ A. ∀b ∈ A. ¬(a < b)"
using assms
proof (induction A rule: finite_induct)
case (insert a A) thus ?case
by (cases "A = {}", simp, metis insert_iff order_trans less_le_not_le)
qed simp
lemma partition_index_bij:
fixes n::nat
obtains I k where
"bij_betw I {0..<n} {0..<n}" "k ≤ n"
"∀i. i < k ⟶ P (I i)"
"∀i. k ≤ i ∧ i < n ⟶ ¬(P (I i))"
proof -
define A where "A = filter P [0..<n]"
define B where "B = filter (λi. ¬P i) [0..<n]"
define k where "k = length A"
define I where "I = (λn. (A@B) ! n)"
note defs = A_def B_def k_def I_def
have k1: "k ≤ n" by (metis defs(1,3) diff_le_self dual_order.trans length_filter_le length_upt)
have "i < k ⟹ P (A ! i)" for i by (metis defs(1,3) filter_nth)
hence k2: "i < k ⟹ P ((A@B) ! i)" for i by (simp add: defs nth_append)
have "i < length B ⟹ ¬(P (B ! i))" for i by (metis defs(2) filter_nth)
hence "i < length B ⟹ ¬(P ((A@B) ! (k + i)))" for i using k_def by simp
hence "k ≤ i ∧ i < k + length B ⟹ ¬(P ((A@B) ! i))" for i
by (metis add.commute add_less_imp_less_right le_add_diff_inverse2)
hence k3: "k ≤ i ∧ i < n ⟹ ¬(P ((A@B) ! i))" for i by (simp add: defs sum_length_filter_compl)
have *: "length (A@B) = n" "set (A@B) = {0..<n}" "distinct (A@B)"
by (metis defs(1,2) diff_zero length_append length_upt sum_length_filter_compl)
(auto simp add: defs)
have I: "bij_betw I {0..<n} {0..<n}"
proof (intro bij_betwI')
fix x y show "x ∈ {0..<n} ⟹ y ∈ {0..<n} ⟹ (I x = I y) = (x = y)"
by (metis *(1,3) defs(4) nth_eq_iff_index_eq atLeastLessThan_iff)
next
fix x show "x ∈ {0..<n} ⟹ I x ∈ {0..<n}"
by (metis *(1,2) defs(4) atLeastLessThan_iff nth_mem)
next
fix y show "y ∈ {0..<n} ⟹ ∃x ∈ {0..<n}. y = I x"
by (metis * defs(4) atLeast0LessThan distinct_Ex1 lessThan_iff)
qed
show ?thesis using k1 k2 k3 I that by (simp add: defs)
qed
lemma finite_lists_length_eq':
assumes "⋀x. x ∈ set xs ⟹ finite {y. P x y}"
shows "finite {ys. length xs = length ys ∧ (∀y ∈ set ys. ∃x ∈ set xs. P x y)}"
proof -
define Q where "Q ≡ λys. ∀y ∈ set ys. ∃x ∈ set xs. P x y"
define M where "M ≡ {y. ∃x ∈ set xs. P x y}"
have 0: "finite M" using assms unfolding M_def by fastforce
have "Q ys ⟷ set ys ⊆ M"
"(Q ys ∧ length ys = length xs) ⟷ (length xs = length ys ∧ Q ys)"
for ys
unfolding Q_def M_def by auto
thus ?thesis
using finite_lists_length_eq[OF 0, of "length xs"]
unfolding Q_def by presburger
qed
lemma trancl_eqI:
assumes "∀(a,b) ∈ A. ∀(c,d) ∈ A. b = c ⟶ (a,d) ∈ A"
shows "A = A⇧+"
proof
show "A⇧+ ⊆ A"
proof
fix x assume x: "x ∈ A⇧+"
then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
hence "(a,b) ∈ A⇧+" using x by metis
hence "(a,b) ∈ A" using assms by (induct rule: trancl_induct) auto
thus "x ∈ A" using ab by metis
qed
qed auto
lemma trancl_eqI':
assumes "∀(a,b) ∈ A. ∀(c,d) ∈ A. b = c ∧ a ≠ d ⟶ (a,d) ∈ A"
and "∀(a,b) ∈ A. a ≠ b"
shows "A = {(a,b) ∈ A⇧+. a ≠ b}"
proof
show "{(a,b) ∈ A⇧+. a ≠ b} ⊆ A"
proof
fix x assume x: "x ∈ {(a,b) ∈ A⇧+. a ≠ b}"
then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
hence "(a,b) ∈ A⇧+" "a ≠ b" using x by blast+
hence "(a,b) ∈ A"
proof (induction rule: trancl_induct)
case base thus ?case by blast
next
case step thus ?case using assms(1) by force
qed
thus "x ∈ A" using ab by metis
qed
qed (use assms(2) in auto)
lemma distinct_concat_idx_disjoint:
assumes xs: "distinct (concat xs)"
and ij: "i < length xs" "j < length xs" "i < j"
shows "set (xs ! i) ∩ set (xs ! j) = {}"
proof -
obtain ys zs vs where ys: "xs = ys@xs ! i#zs@xs ! j#vs" "length ys = i" "length zs = j - i - 1"
using length_prefix_ex2[OF ij] by moura
thus ?thesis
using xs concat_append[of "ys@xs ! i#zs" "xs ! j#vs"]
distinct_append[of "concat (ys@xs ! i#zs)" "concat (xs ! j#vs)"]
by auto
qed
lemma remdups_ex2:
"length (remdups xs) > 1 ⟹ ∃a ∈ set xs. ∃b ∈ set xs. a ≠ b"
by (metis distinct_Ex1 distinct_remdups less_trans nth_mem set_remdups zero_less_one zero_neq_one)
lemma trancl_minus_refl_idem:
defines "cl ≡ λts. {(a,b) ∈ ts⇧+. a ≠ b}"
shows "cl (cl ts) = cl ts"
proof -
have 0: "(ts⇧+)⇧+ = ts⇧+" "cl ts ⊆ ts⇧+" "(cl ts)⇧+ ⊆ (ts⇧+)⇧+"
proof -
show "(ts⇧+)⇧+ = ts⇧+" "cl ts ⊆ ts⇧+" unfolding cl_def by auto
thus "(cl ts)⇧+ ⊆ (ts⇧+)⇧+" using trancl_mono[of _ "cl ts" "ts⇧+"] by blast
qed
have 1: "t ∈ cl (cl ts)" when t: "t ∈ cl ts" for t
using t 0 unfolding cl_def by fast
have 2: "t ∈ cl ts" when t: "t ∈ cl (cl ts)" for t
proof -
obtain a b where ab: "t = (a,b)" by (metis surj_pair)
have "t ∈ (cl ts)⇧+" and a_neq_b: "a ≠ b" using t unfolding cl_def ab by force+
hence "t ∈ ts⇧+" using 0 by blast
thus ?thesis using a_neq_b unfolding cl_def ab by blast
qed
show ?thesis using 1 2 by blast
qed
subsection ‹Infinite Paths in Relations as Mappings from Naturals to States›
context
begin
private fun rel_chain_fun::"nat ⇒ 'a ⇒ 'a ⇒ ('a × 'a) set ⇒ 'a" where
"rel_chain_fun 0 x _ _ = x"
| "rel_chain_fun (Suc i) x y r = (if i = 0 then y else SOME z. (rel_chain_fun i x y r, z) ∈ r)"
lemma infinite_chain_intro:
fixes r::"('a × 'a) set"
assumes "∀(a,b) ∈ r. ∃c. (b,c) ∈ r" "r ≠ {}"
shows "∃f. ∀i::nat. (f i, f (Suc i)) ∈ r"
proof -
from assms(2) obtain a b where "(a,b) ∈ r" by auto
let ?P = "λi. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) ∈ r"
let ?Q = "λi. ∃z. (rel_chain_fun i a b r, z) ∈ r"
have base: "?P 0" using ‹(a,b) ∈ r› by auto
have step: "?P (Suc i)" when i: "?P i" for i
proof -
have "?Q (Suc i)" using assms(1) i by auto
thus ?thesis using someI_ex[OF ‹?Q (Suc i)›] by auto
qed
have "∀i::nat. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) ∈ r"
using base step nat_induct[of ?P] by simp
thus ?thesis by fastforce
qed
end
lemma infinite_chain_intro':
fixes r::"('a × 'a) set"
assumes base: "∃b. (x,b) ∈ r" and step: "∀b. (x,b) ∈ r⇧+ ⟶ (∃c. (b,c) ∈ r)"
shows "∃f. ∀i::nat. (f i, f (Suc i)) ∈ r"
proof -
let ?s = "{(a,b) ∈ r. a = x ∨ (x,a) ∈ r⇧+}"
have "?s ≠ {}" using base by auto
have "∃c. (b,c) ∈ ?s" when ab: "(a,b) ∈ ?s" for a b
proof (cases "a = x")
case False
hence "(x,a) ∈ r⇧+" using ab by auto
hence "(x,b) ∈ r⇧+" using ‹(a,b) ∈ ?s› by auto
thus ?thesis using step by auto
qed (use ab step in auto)
hence "∃f. ∀i. (f i, f (Suc i)) ∈ ?s" using infinite_chain_intro[of ?s] ‹?s ≠ {}› by blast
thus ?thesis by auto
qed
lemma infinite_chain_mono:
assumes "S ⊆ T" "∃f. ∀i::nat. (f i, f (Suc i)) ∈ S"
shows "∃f. ∀i::nat. (f i, f (Suc i)) ∈ T"
using assms by auto
end
Theory Messages
section ‹Protocol Messages as (First-Order) Terms›
theory Messages
imports Miscellaneous "First_Order_Terms.Term"
begin
subsection ‹Term-related definitions: subterms and free variables›
abbreviation "the_Fun ≡ un_Fun1"
lemmas the_Fun_def = un_Fun1_def
fun subterms::"('a,'b) term ⇒ ('a,'b) terms" where
"subterms (Var x) = {Var x}"
| "subterms (Fun f T) = {Fun f T} ∪ (⋃t ∈ set T. subterms t)"
abbreviation subtermeq (infix "⊑" 50) where "t' ⊑ t ≡ (t' ∈ subterms t)"
abbreviation subterm (infix "⊏" 50) where "t' ⊏ t ≡ (t' ⊑ t ∧ t' ≠ t)"
abbreviation "subterms⇩s⇩e⇩t M ≡ ⋃(subterms ` M)"
abbreviation subtermeqset (infix "⊑⇩s⇩e⇩t" 50) where "t ⊑⇩s⇩e⇩t M ≡ (t ∈ subterms⇩s⇩e⇩t M)"
abbreviation fv where "fv ≡ vars_term"
lemmas fv_simps = term.simps(17,18)
fun fv⇩s⇩e⇩t where "fv⇩s⇩e⇩t M = ⋃(fv ` M)"
abbreviation fv⇩p⇩a⇩i⇩r where "fv⇩p⇩a⇩i⇩r p ≡ case p of (t,t') ⇒ fv t ∪ fv t'"
fun fv⇩p⇩a⇩i⇩r⇩s where "fv⇩p⇩a⇩i⇩r⇩s F = ⋃(fv⇩p⇩a⇩i⇩r ` set F)"
abbreviation ground where "ground M ≡ fv⇩s⇩e⇩t M = {}"
subsection ‹Variants that return lists insteads of sets›
fun fv_list where
"fv_list (Var x) = [x]"
| "fv_list (Fun f T) = concat (map fv_list T)"
definition fv_list⇩p⇩a⇩i⇩r⇩s where
"fv_list⇩p⇩a⇩i⇩r⇩s F ≡ concat (map (λ(t,t'). fv_list t@fv_list t') F)"
fun subterms_list::"('a,'b) term ⇒ ('a,'b) term list" where
"subterms_list (Var x) = [Var x]"
| "subterms_list (Fun f T) = remdups (Fun f T#concat (map subterms_list T))"
lemma fv_list_is_fv: "fv t = set (fv_list t)"
by (induct t) auto
lemma fv_list⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s: "fv⇩p⇩a⇩i⇩r⇩s F = set (fv_list⇩p⇩a⇩i⇩r⇩s F)"
by (induct F) (auto simp add: fv_list_is_fv fv_list⇩p⇩a⇩i⇩r⇩s_def)
lemma subterms_list_is_subterms: "subterms t = set (subterms_list t)"
by (induct t) auto
subsection ‹The subterm relation defined as a function›
fun subterm_of where
"subterm_of t (Var y) = (t = Var y)"
| "subterm_of t (Fun f T) = (t = Fun f T ∨ list_ex (subterm_of t) T)"
lemma subterm_of_iff_subtermeq[code_unfold]: "t ⊑ t' = subterm_of t t'"
proof (induction t')
case (Fun f T) thus ?case
proof (cases "t = Fun f T")
case False thus ?thesis
using Fun.IH subterm_of.simps(2)[of t f T]
unfolding list_ex_iff by fastforce
qed simp
qed simp
lemma subterm_of_ex_set_iff_subtermeqset[code_unfold]: "t ⊑⇩s⇩e⇩t M = (∃t' ∈ M. subterm_of t t')"
using subterm_of_iff_subtermeq by blast
subsection ‹The subterm relation is a partial order on terms›
interpretation "term": ordering "(⊑)" "(⊏)"
proof
show "s ⊑ s" for s :: "('a,'b) term"
by (induct s rule: subterms.induct) auto
show trans: "s ⊑ t ⟹ t ⊑ u ⟹ s ⊑ u" for s t u :: "('a,'b) term"
by (induct u rule: subterms.induct) auto
show "s ⊑ t ⟹ t ⊑ s ⟹ s = t" for s t :: "('a,'b) term"
proof (induction s arbitrary: t rule: subterms.induct[case_names Var Fun])
case (Fun f T)
{ assume 0: "t ≠ Fun f T"
then obtain u::"('a,'b) term" where u: "u ∈ set T" "t ⊑ u" using Fun.prems(2) by auto
hence 1: "Fun f T ⊑ u" using trans[OF Fun.prems(1)] by simp
have 2: "u ⊑ Fun f T"
by (cases u) (use u(1) in force, use u(1) subterms.simps(2)[of f T] in fastforce)
hence 3: "u = Fun f T" using Fun.IH[OF u(1) _ 1] by simp
have "u ⊑ t" using trans[OF 2 Fun.prems(1)] by simp
hence 4: "u = t" using Fun.IH[OF u(1) _ u(2)] by simp
have "t = Fun f T" using 3 4 by simp
hence False using 0 by simp
}
thus ?case by auto
qed simp
show ‹s ⊏ t ⟷ s ⊏ t› for s t :: "('a,'b) term" ..
qed
interpretation "term": order "(⊑)" "(⊏)"
by (rule ordering_orderI) (fact term.ordering_axioms)
subsection ‹Lemmata concerning subterms and free variables›
lemma fv_list⇩p⇩a⇩i⇩r⇩s_append: "fv_list⇩p⇩a⇩i⇩r⇩s (F@G) = fv_list⇩p⇩a⇩i⇩r⇩s F@fv_list⇩p⇩a⇩i⇩r⇩s G"
by (simp add: fv_list⇩p⇩a⇩i⇩r⇩s_def)
lemma distinct_fv_list_idx_fv_disjoint:
assumes t: "distinct (fv_list t)" "Fun f T ⊑ t"
and ij: "i < length T" "j < length T" "i < j"
shows "fv (T ! i) ∩ fv (T ! j) = {}"
using t
proof (induction t rule: fv_list.induct)
case (2 g S)
have "distinct (fv_list s)" when s: "s ∈ set S" for s
by (metis (no_types, lifting) s "2.prems"(1) concat_append distinct_append
map_append split_list fv_list.simps(2) concat.simps(2) list.simps(9))
hence IH: "fv (T ! i) ∩ fv (T ! j) = {}"
when s: "s ∈ set S" "Fun f T ⊑ s" for s
using "2.IH" s by blast
show ?case
proof (cases "Fun f T = Fun g S")
case True
define U where "U ≡ map fv_list T"
have a: "distinct (concat U)"
using "2.prems"(1) True unfolding U_def by auto
have b: "i < length U" "j < length U"
using ij(1,2) unfolding U_def by simp_all
show ?thesis
using b distinct_concat_idx_disjoint[OF a b ij(3)]
fv_list_is_fv[of "T ! i"] fv_list_is_fv[of "T ! j"]
unfolding U_def by force
qed (use IH "2.prems"(2) in auto)
qed force
lemmas subtermeqI'[intro] = term.eq_refl
lemma subtermeqI''[intro]: "t ∈ set T ⟹ t ⊑ Fun f T"
by force
lemma finite_fv_set[intro]: "finite M ⟹ finite (fv⇩s⇩e⇩t M)"
by auto
lemma finite_fun_symbols[simp]: "finite (funs_term t)"
by (induct t) simp_all
lemma fv_set_mono: "M ⊆ N ⟹ fv⇩s⇩e⇩t M ⊆ fv⇩s⇩e⇩t N"
by auto
lemma subterms⇩s⇩e⇩t_mono: "M ⊆ N ⟹ subterms⇩s⇩e⇩t M ⊆ subterms⇩s⇩e⇩t N"
by auto
lemma ground_empty[simp]: "ground {}"
by simp
lemma ground_subset: "M ⊆ N ⟹ ground N ⟹ ground M"
by auto
lemma fv_map_fv_set: "⋃(set (map fv L)) = fv⇩s⇩e⇩t (set L)"
by (induct L) auto
lemma fv⇩s⇩e⇩t_union: "fv⇩s⇩e⇩t (M ∪ N) = fv⇩s⇩e⇩t M ∪ fv⇩s⇩e⇩t N"
by auto
lemma finite_subset_Union:
fixes A::"'a set" and f::"'a ⇒ 'b set"
assumes "finite (⋃a ∈ A. f a)"
shows "∃B. finite B ∧ B ⊆ A ∧ (⋃b ∈ B. f b) = (⋃a ∈ A. f a)"
by (metis assms eq_iff finite_subset_image finite_UnionD)
lemma inv_set_fv: "finite M ⟹ ⋃(set (map fv (inv set M))) = fv⇩s⇩e⇩t M"
using fv_map_fv_set[of "inv set M"] inv_set_fset by auto
lemma ground_subterm: "fv t = {} ⟹ t' ⊑ t ⟹ fv t' = {}" by (induct t) auto
lemma empty_fv_not_var: "fv t = {} ⟹ t ≠ Var x" by auto
lemma empty_fv_exists_fun: "fv t = {} ⟹ ∃f X. t = Fun f X" by (cases t) auto
lemma vars_iff_subtermeq: "x ∈ fv t ⟷ Var x ⊑ t" by (induct t) auto
lemma vars_iff_subtermeq_set: "x ∈ fv⇩s⇩e⇩t M ⟷ Var x ∈ subterms⇩s⇩e⇩t M"
using vars_iff_subtermeq[of x] by auto
lemma vars_if_subtermeq_set: "Var x ∈ subterms⇩s⇩e⇩t M ⟹ x ∈ fv⇩s⇩e⇩t M"
by (metis vars_iff_subtermeq_set)
lemma subtermeq_set_if_vars: "x ∈ fv⇩s⇩e⇩t M ⟹ Var x ∈ subterms⇩s⇩e⇩t M"
by (metis vars_iff_subtermeq_set)
lemma vars_iff_subterm_or_eq: "x ∈ fv t ⟷ Var x ⊏ t ∨ Var x = t"
by (induct t) (auto simp add: vars_iff_subtermeq)
lemma var_is_subterm: "x ∈ fv t ⟹ Var x ∈ subterms t"
by (simp add: vars_iff_subtermeq)
lemma subterm_is_var: "Var x ∈ subterms t ⟹ x ∈ fv t"
by (simp add: vars_iff_subtermeq)
lemma no_var_subterm: "¬t ⊏ Var v" by auto
lemma fun_if_subterm: "t ⊏ u ⟹ ∃f X. u = Fun f X" by (induct u) simp_all
lemma subtermeq_vars_subset: "M ⊑ N ⟹ fv M ⊆ fv N" by (induct N) auto
lemma fv_subterms[simp]: "fv⇩s⇩e⇩t (subterms t) = fv t"
by (induct t) auto
lemma fv_subterms_set[simp]: "fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t M) = fv⇩s⇩e⇩t M"
using subtermeq_vars_subset by auto
lemma fv_subset: "t ∈ M ⟹ fv t ⊆ fv⇩s⇩e⇩t M"
by auto
lemma fv_subset_subterms: "t ∈ subterms⇩s⇩e⇩t M ⟹ fv t ⊆ fv⇩s⇩e⇩t M"
using fv_subset fv_subterms_set by metis
lemma subterms_finite[simp]: "finite (subterms t)" by (induction rule: subterms.induct) auto
lemma subterms_union_finite: "finite M ⟹ finite (⋃t ∈ M. subterms t)"
by (induction rule: subterms.induct) auto
lemma subterms_subset: "t' ⊑ t ⟹ subterms t' ⊆ subterms t"
by (induction rule: subterms.induct) auto
lemma subterms_subset_set: "M ⊆ subterms t ⟹ subterms⇩s⇩e⇩t M ⊆ subterms t"
by (metis SUP_least contra_subsetD subterms_subset)
lemma subset_subterms_Union[simp]: "M ⊆ subterms⇩s⇩e⇩t M" by auto
lemma in_subterms_Union: "t ∈ M ⟹ t ∈ subterms⇩s⇩e⇩t M" using subset_subterms_Union by blast
lemma in_subterms_subset_Union: "t ∈ subterms⇩s⇩e⇩t M ⟹ subterms t ⊆ subterms⇩s⇩e⇩t M"
using subterms_subset by auto
lemma subterm_param_split:
assumes "t ⊏ Fun f X"
shows "∃pre x suf. t ⊑ x ∧ X = pre@x#suf"
proof -
obtain x where "t ⊑ x" "x ∈ set X" using assms by auto
then obtain pre suf where "X = pre@x#suf" "x ∉ set pre ∨ x ∉ set suf"
by (meson split_list_first split_list_last)
thus ?thesis using ‹t ⊑ x› by auto
qed
lemma ground_iff_no_vars: "ground (M::('a,'b) terms) ⟷ (∀v. Var v ∉ (⋃m ∈ M. subterms m))"
proof
assume "ground M"
hence "∀v. ∀m ∈ M. v ∉ fv m" by auto
hence "∀v. ∀m ∈ M. Var v ∉ subterms m" by (simp add: vars_iff_subtermeq)
thus "(∀v. Var v ∉ (⋃m ∈ M. subterms m))" by simp
next
assume no_vars: "∀v. Var v ∉ (⋃m ∈ M. subterms m)"
moreover
{ assume "¬ground M"
then obtain v and m::"('a,'b) term" where "m ∈ M" "fv m ≠ {}" "v ∈ fv m" by auto
hence "Var v ∈ (subterms m)" by (simp add: vars_iff_subtermeq)
hence "∃v. Var v ∈ (⋃t ∈ M. subterms t)" using ‹m ∈ M› by auto
hence False using no_vars by simp
}
ultimately show "ground M" by blast
qed
lemma index_Fun_subterms_subset[simp]: "i < length T ⟹ subterms (T ! i) ⊆ subterms (Fun f T)"
by auto
lemma index_Fun_fv_subset[simp]: "i < length T ⟹ fv (T ! i) ⊆ fv (Fun f T)"
using subtermeq_vars_subset by fastforce
lemma subterms_union_ground:
assumes "ground M"
shows "ground (subterms⇩s⇩e⇩t M)"
proof -
{ fix t assume "t ∈ M"
hence "fv t = {}"
using ground_iff_no_vars[of M] assms
by auto
hence "∀t' ∈ subterms t. fv t' = {}" using subtermeq_vars_subset[of _ t] by simp
hence "ground (subterms t)" by auto
}
thus ?thesis by auto
qed
lemma Var_subtermeq: "t ⊑ Var v ⟹ t = Var v" by simp
lemma subtermeq_imp_funs_term_subset: "s ⊑ t ⟹ funs_term s ⊆ funs_term t"
by (induct t arbitrary: s) auto
lemma subterms_const: "subterms (Fun f []) = {Fun f []}" by simp
lemma subterm_subtermeq_neq: "⟦t ⊏ u; u ⊑ v⟧ ⟹ t ≠ v"
by (metis term.eq_iff)
lemma subtermeq_subterm_neq: "⟦t ⊑ u; u ⊏ v⟧ ⟹ t ≠ v"
by (metis term.eq_iff)
lemma subterm_size_lt: "x ⊏ y ⟹ size x < size y"
using not_less_eq size_list_estimation by (induct y, simp, fastforce)
lemma in_subterms_eq: "⟦x ∈ subterms y; y ∈ subterms x⟧ ⟹ subterms x = subterms y"
using term.antisym by auto
lemma Fun_gt_params: "Fun f X ∉ (⋃x ∈ set X. subterms x)"
proof -
have "size_list size X < size (Fun f X)" by simp
hence "Fun f X ∉ set X" by (meson less_not_refl size_list_estimation)
hence "∀x ∈ set X. Fun f X ∉ subterms x ∨ x ∉ subterms (Fun f X)"
by (metis term.antisym[of "Fun f X" _])
moreover have "∀x ∈ set X. x ∈ subterms (Fun f X)" by fastforce
ultimately show ?thesis by auto
qed
lemma params_subterms[simp]: "set X ⊆ subterms (Fun f X)" by auto
lemma params_subterms_Union[simp]: "subterms⇩s⇩e⇩t (set X) ⊆ subterms (Fun f X)" by auto
lemma Fun_subterm_inside_params: "t ⊏ Fun f X ⟷ t ∈ (⋃x ∈ (set X). subterms x)"
using Fun_gt_params by fastforce
lemma Fun_param_is_subterm: "x ∈ set X ⟹ x ⊏ Fun f X"
using Fun_subterm_inside_params by fastforce
lemma Fun_param_in_subterms: "x ∈ set X ⟹ x ∈ subterms (Fun f X)"
using Fun_subterm_inside_params by fastforce
lemma Fun_not_in_param: "x ∈ set X ⟹ ¬Fun f X ⊏ x"
using term.antisym by fast
lemma Fun_ex_if_subterm: "t ⊏ s ⟹ ∃f T. Fun f T ⊑ s ∧ t ∈ set T"
proof (induction s)
case (Fun f T)
then obtain s' where s': "s' ∈ set T" "t ⊑ s'" by auto
show ?case
proof (cases "t = s'")
case True thus ?thesis using s' by blast
next
case False
thus ?thesis
using Fun.IH[OF s'(1)] s'(2) term.order_trans[OF _ Fun_param_in_subterms[OF s'(1), of f]]
by metis
qed
qed simp
lemma const_subterm_obtain:
assumes "fv t = {}"
obtains c where "Fun c [] ⊑ t"
using assms
proof (induction t)
case (Fun f T) thus ?case by (cases "T = []") force+
qed simp
lemma const_subterm_obtain': "fv t = {} ⟹ ∃c. Fun c [] ⊑ t"
by (metis const_subterm_obtain)
lemma subterms_singleton:
assumes "(∃v. t = Var v) ∨ (∃f. t = Fun f [])"
shows "subterms t = {t}"
using assms by (cases t) auto
lemma subtermeq_Var_const:
assumes "s ⊑ t"
shows "t = Var v ⟹ s = Var v" "t = Fun f [] ⟹ s = Fun f []"
using assms by fastforce+
lemma subterms_singleton':
assumes "subterms t = {t}"
shows "(∃v. t = Var v) ∨ (∃f. t = Fun f [])"
proof (cases t)
case (Fun f T)
{ fix s S assume "T = s#S"
hence "s ∈ subterms t" using Fun by auto
hence "s = t" using assms by auto
hence False
using Fun_param_is_subterm[of s "s#S" f] ‹T = s#S› Fun
by auto
}
hence "T = []" by (cases T) auto
thus ?thesis using Fun by simp
qed (simp add: assms)
lemma funs_term_subterms_eq[simp]:
"(⋃s ∈ subterms t. funs_term s) = funs_term t"
"(⋃s ∈ subterms⇩s⇩e⇩t M. funs_term s) = ⋃(funs_term ` M)"
proof -
show "⋀t. ⋃(funs_term ` subterms t) = funs_term t"
using term.order_refl subtermeq_imp_funs_term_subset by blast
thus "⋃(funs_term ` (subterms⇩s⇩e⇩t M)) = ⋃(funs_term ` M)" by force
qed
lemmas subtermI'[intro] = Fun_param_is_subterm
lemma funs_term_Fun_subterm: "f ∈ funs_term t ⟹ ∃T. Fun f T ∈ subterms t"
proof (induction t)
case (Fun g T)
hence "f = g ∨ (∃s ∈ set T. f ∈ funs_term s)" by simp
thus ?case
proof
assume "∃s ∈ set T. f ∈ funs_term s"
then obtain s where "s ∈ set T" "∃T. Fun f T ∈ subterms s" using Fun.IH by auto
thus ?thesis by auto
qed (auto simp add: Fun)
qed simp
lemma funs_term_Fun_subterm': "Fun f T ∈ subterms t ⟹ f ∈ funs_term t"
by (induct t) auto
lemma zip_arg_subterm:
assumes "(s,t) ∈ set (zip X Y)"
shows "s ⊏ Fun f X" "t ⊏ Fun g Y"
proof -
from assms have *: "s ∈ set X" "t ∈ set Y" by (meson in_set_zipE)+
show "s ⊏ Fun f X" by (metis Fun_param_is_subterm[OF *(1)])
show "t ⊏ Fun g Y" by (metis Fun_param_is_subterm[OF *(2)])
qed
lemma fv_disj_Fun_subterm_param_cases:
assumes "fv t ∩ X = {}" "Fun f T ∈ subterms t"
shows "T = [] ∨ (∃s∈set T. s ∉ Var ` X)"
proof (cases T)
case (Cons s S)
hence "s ∈ subterms t"
using assms(2) term.order_trans[of _ "Fun f T" t]
by auto
hence "fv s ∩ X = {}" using assms(1) fv_subterms by force
thus ?thesis using Cons by auto
qed simp
lemma fv_eq_FunI:
assumes "length T = length S" "⋀i. i < length T ⟹ fv (T ! i) = fv (S ! i)"
shows "fv (Fun f T) = fv (Fun g S)"
using assms
proof (induction T arbitrary: S)
case (Cons t T S')
then obtain s S where S': "S' = s#S" by (cases S') simp_all
thus ?case using Cons by fastforce
qed simp
lemma fv_eq_FunI':
assumes "length T = length S" "⋀i. i < length T ⟹ x ∈ fv (T ! i) ⟷ x ∈ fv (S ! i)"
shows "x ∈ fv (Fun f T) ⟷ x ∈ fv (Fun g S)"
using assms
proof (induction T arbitrary: S)
case (Cons t T S')
then obtain s S where S': "S' = s#S" by (cases S') simp_all
thus ?case using Cons by fastforce
qed simp
lemma finite_fv⇩p⇩a⇩i⇩r⇩s[simp]: "finite (fv⇩p⇩a⇩i⇩r⇩s x)" by auto
lemma fv⇩p⇩a⇩i⇩r⇩s_Nil[simp]: "fv⇩p⇩a⇩i⇩r⇩s [] = {}" by simp
lemma fv⇩p⇩a⇩i⇩r⇩s_singleton[simp]: "fv⇩p⇩a⇩i⇩r⇩s [(t,s)] = fv t ∪ fv s" by simp
lemma fv⇩p⇩a⇩i⇩r⇩s_Cons: "fv⇩p⇩a⇩i⇩r⇩s ((s,t)#F) = fv s ∪ fv t ∪ fv⇩p⇩a⇩i⇩r⇩s F" by simp
lemma fv⇩p⇩a⇩i⇩r⇩s_append: "fv⇩p⇩a⇩i⇩r⇩s (F@G) = fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G" by simp
lemma fv⇩p⇩a⇩i⇩r⇩s_mono: "set M ⊆ set N ⟹ fv⇩p⇩a⇩i⇩r⇩s M ⊆ fv⇩p⇩a⇩i⇩r⇩s N" by auto
lemma fv⇩p⇩a⇩i⇩r⇩s_inI[intro]:
"f ∈ set F ⟹ x ∈ fv⇩p⇩a⇩i⇩r f ⟹ x ∈ fv⇩p⇩a⇩i⇩r⇩s F"
"f ∈ set F ⟹ x ∈ fv (fst f) ⟹ x ∈ fv⇩p⇩a⇩i⇩r⇩s F"
"f ∈ set F ⟹ x ∈ fv (snd f) ⟹ x ∈ fv⇩p⇩a⇩i⇩r⇩s F"
"(t,s) ∈ set F ⟹ x ∈ fv t ⟹ x ∈ fv⇩p⇩a⇩i⇩r⇩s F"
"(t,s) ∈ set F ⟹ x ∈ fv s ⟹ x ∈ fv⇩p⇩a⇩i⇩r⇩s F"
using UN_I by fastforce+
lemma fv⇩p⇩a⇩i⇩r⇩s_cons_subset: "fv⇩p⇩a⇩i⇩r⇩s F ⊆ fv⇩p⇩a⇩i⇩r⇩s (f#F)"
by auto
subsection ‹Other lemmata›
lemma nonvar_term_has_composed_shallow_term:
fixes t::"('f,'v) term"
assumes "¬(∃x. t = Var x)"
shows "∃f T. Fun f T ⊑ t ∧ (∀s ∈ set T. (∃c. s = Fun c []) ∨ (∃x. s = Var x))"
proof -
let ?Q = "λS. ∀s ∈ set S. (∃c. s = Fun c []) ∨ (∃x. s = Var x)"
let ?P = "λt. ∃g S. Fun g S ⊑ t ∧ ?Q S"
{ fix t::"('f,'v) term"
have "(∃x. t = Var x) ∨ ?P t"
proof (induction t)
case (Fun h R) show ?case
proof (cases "R = [] ∨ (∀r ∈ set R. ∃x. r = Var x)")
case False
then obtain r g S where "r ∈ set R" "?P r" "Fun g S ⊑ r" "?Q S" using Fun.IH by fast
thus ?thesis by auto
qed force
qed simp
} thus ?thesis using assms by blast
qed
end
Theory More_Unification
section ‹Definitions and Properties Related to Substitutions and Unification›
theory More_Unification
imports Messages "First_Order_Terms.Unification"
begin
subsection ‹Substitutions›
abbreviation subst_apply_list (infix "⋅⇩l⇩i⇩s⇩t" 51) where
"T ⋅⇩l⇩i⇩s⇩t θ ≡ map (λt. t ⋅ θ) T"
abbreviation subst_apply_pair (infixl "⋅⇩p" 60) where
"d ⋅⇩p θ ≡ (case d of (t,t') ⇒ (t ⋅ θ, t' ⋅ θ))"
abbreviation subst_apply_pair_set (infixl "⋅⇩p⇩s⇩e⇩t" 60) where
"M ⋅⇩p⇩s⇩e⇩t θ ≡ (λd. d ⋅⇩p θ) ` M"
definition subst_apply_pairs (infix "⋅⇩p⇩a⇩i⇩r⇩s" 51) where
"F ⋅⇩p⇩a⇩i⇩r⇩s θ ≡ map (λf. f ⋅⇩p θ) F"
abbreviation subst_more_general_than (infixl "≼⇩∘" 50) where
"σ ≼⇩∘ θ ≡ ∃γ. θ = σ ∘⇩s γ"
abbreviation subst_support (infix "supports" 50) where
"θ supports δ ≡ (∀x. θ x ⋅ δ = δ x)"
abbreviation rm_var where
"rm_var v s ≡ s(v := Var v)"
abbreviation rm_vars where
"rm_vars vs σ ≡ (λv. if v ∈ vs then Var v else σ v)"
definition subst_elim where
"subst_elim σ v ≡ ∀t. v ∉ fv (t ⋅ σ)"
definition subst_idem where
"subst_idem s ≡ s ∘⇩s s = s"
lemma subst_support_def: "θ supports τ ⟷ τ = θ ∘⇩s τ"
unfolding subst_compose_def by metis
lemma subst_supportD: "θ supports δ ⟹ θ ≼⇩∘ δ"
using subst_support_def by auto
lemma rm_vars_empty[simp]: "rm_vars {} s = s" "rm_vars (set []) s = s"
by simp_all
lemma rm_vars_singleton: "rm_vars {v} s = rm_var v s"
by auto
lemma subst_apply_terms_empty: "M ⋅⇩s⇩e⇩t Var = M"
by simp
lemma subst_agreement: "(t ⋅ r = t ⋅ s) ⟷ (∀v ∈ fv t. Var v ⋅ r = Var v ⋅ s)"
by (induct t) auto
lemma repl_invariance[dest?]: "v ∉ fv t ⟹ t ⋅ s(v := u) = t ⋅ s"
by (simp add: subst_agreement)
lemma subst_idx_map:
assumes "∀i ∈ set I. i < length T"
shows "(map ((!) T) I) ⋅⇩l⇩i⇩s⇩t δ = map ((!) (map (λt. t ⋅ δ) T)) I"
using assms by auto
lemma subst_idx_map':
assumes "∀i ∈ fv⇩s⇩e⇩t (set K). i < length T"
shows "(K ⋅⇩l⇩i⇩s⇩t (!) T) ⋅⇩l⇩i⇩s⇩t δ = K ⋅⇩l⇩i⇩s⇩t ((!) (map (λt. t ⋅ δ) T))" (is "?A = ?B")
proof -
have "T ! i ⋅ δ = (map (λt. t ⋅ δ) T) ! i"
when "i < length T" for i
using that by auto
hence "T ! i ⋅ δ = (map (λt. t ⋅ δ) T) ! i"
when "i ∈ fv⇩s⇩e⇩t (set K)" for i
using that assms by auto
hence "k ⋅ (!) T ⋅ δ = k ⋅ (!) (map (λt. t ⋅ δ) T)"
when "fv k ⊆ fv⇩s⇩e⇩t (set K)" for k
using that by (induction k) force+
thus ?thesis by auto
qed
lemma subst_remove_var: "v ∉ fv s ⟹ v ∉ fv (t ⋅ Var(v := s))"
by (induct t) simp_all
lemma subst_set_map: "x ∈ set X ⟹ x ⋅ s ∈ set (map (λx. x ⋅ s) X)"
by simp
lemma subst_set_idx_map:
assumes "∀i ∈ I. i < length T"
shows "(!) T ` I ⋅⇩s⇩e⇩t δ = (!) (map (λt. t ⋅ δ) T) ` I" (is "?A = ?B")
proof
have *: "T ! i ⋅ δ = (map (λt. t ⋅ δ) T) ! i"
when "i < length T" for i
using that by auto
show "?A ⊆ ?B" using * assms by blast
show "?B ⊆ ?A" using * assms by auto
qed
lemma subst_set_idx_map':
assumes "∀i ∈ fv⇩s⇩e⇩t K. i < length T"
shows "K ⋅⇩s⇩e⇩t (!) T ⋅⇩s⇩e⇩t δ = K ⋅⇩s⇩e⇩t (!) (map (λt. t ⋅ δ) T)" (is "?A = ?B")
proof
have "T ! i ⋅ δ = (map (λt. t ⋅ δ) T) ! i"
when "i < length T" for i
using that by auto
hence "T ! i ⋅ δ = (map (λt. t ⋅ δ) T) ! i"
when "i ∈ fv⇩s⇩e⇩t K" for i
using that assms by auto
hence *: "k ⋅ (!) T ⋅ δ = k ⋅ (!) (map (λt. t ⋅ δ) T)"
when "fv k ⊆ fv⇩s⇩e⇩t K" for k
using that by (induction k) force+
show "?A ⊆ ?B" using * by auto
show "?B ⊆ ?A" using * by force
qed
lemma subst_term_list_obtain:
assumes "∀i < length T. ∃s. P (T ! i) s ∧ S ! i = s ⋅ δ"
and "length T = length S"
shows "∃U. length T = length U ∧ (∀i < length T. P (T ! i) (U ! i)) ∧ S = map (λu. u ⋅ δ) U"
using assms
proof (induction T arbitrary: S)
case (Cons t T S')
then obtain s S where S': "S' = s#S" by (cases S') auto
have "∀i < length T. ∃s. P (T ! i) s ∧ S ! i = s ⋅ δ" "length T = length S"
using Cons.prems S' by force+
then obtain U where U:
"length T = length U" "∀i < length T. P (T ! i) (U ! i)" "S = map (λu. u ⋅ δ) U"
using Cons.IH by moura
obtain u where u: "P t u" "s = u ⋅ δ"
using Cons.prems(1) S' by auto
have 1: "length (t#T) = length (u#U)"
using Cons.prems(2) U(1) by fastforce
have 2: "∀i < length (t#T). P ((t#T) ! i) ((u#U) ! i)"
using u(1) U(2) by (simp add: nth_Cons')
have 3: "S' = map (λu. u ⋅ δ) (u#U)"
using U u S' by simp
show ?case using 1 2 3 by blast
qed simp
lemma subst_mono: "t ⊑ u ⟹ t ⋅ s ⊑ u ⋅ s"
by (induct u) auto
lemma subst_mono_fv: "x ∈ fv t ⟹ s x ⊑ t ⋅ s"
by (induct t) auto
lemma subst_mono_neq:
assumes "t ⊏ u"
shows "t ⋅ s ⊏ u ⋅ s"
proof (cases u)
case (Var v)
hence False using ‹t ⊏ u› by simp
thus ?thesis ..
next
case (Fun f X)
then obtain x where "x ∈ set X" "t ⊑ x" using ‹t ⊏ u› by auto
hence "t ⋅ s ⊑ x ⋅ s" using subst_mono by metis
obtain Y where "Fun f X ⋅ s = Fun f Y" by auto
hence "x ⋅ s ∈ set Y" using ‹x ∈ set X› by auto
hence "x ⋅ s ⊏ Fun f X ⋅ s" using ‹Fun f X ⋅ s = Fun f Y› Fun_param_is_subterm by simp
hence "t ⋅ s ⊏ Fun f X ⋅ s" using ‹t ⋅ s ⊑ x ⋅ s› by (metis term.dual_order.trans term.eq_iff)
thus ?thesis using ‹u = Fun f X› ‹t ⊏ u› by metis
qed
lemma subst_no_occs[dest]: "¬Var v ⊑ t ⟹ t ⋅ Var(v := s) = t"
by (induct t) (simp_all add: map_idI)
lemma var_comp[simp]: "σ ∘⇩s Var = σ" "Var ∘⇩s σ = σ"
unfolding subst_compose_def by simp_all
lemma subst_comp_all: "M ⋅⇩s⇩e⇩t (δ ∘⇩s θ) = (M ⋅⇩s⇩e⇩t δ) ⋅⇩s⇩e⇩t θ"
using subst_subst_compose[of _ δ θ] by auto
lemma subst_all_mono: "M ⊆ M' ⟹ M ⋅⇩s⇩e⇩t s ⊆ M' ⋅⇩s⇩e⇩t s"
by auto
lemma subst_comp_set_image: "(δ ∘⇩s θ) ` X = δ ` X ⋅⇩s⇩e⇩t θ"
using subst_compose by fastforce
lemma subst_ground_ident[dest?]: "fv t = {} ⟹ t ⋅ s = t"
by (induct t, simp, metis subst_agreement empty_iff subst_apply_term_empty)
lemma subst_ground_ident_compose:
"fv (σ x) = {} ⟹ (σ ∘⇩s θ) x = σ x"
"fv (t ⋅ σ) = {} ⟹ t ⋅ (σ ∘⇩s θ) = t ⋅ σ"
using subst_subst_compose[of t σ θ]
by (simp_all add: subst_compose_def subst_ground_ident)
lemma subst_all_ground_ident[dest?]: "ground M ⟹ M ⋅⇩s⇩e⇩t s = M"
proof -
assume "ground M"
hence "⋀t. t ∈ M ⟹ fv t = {}" by auto
hence "⋀t. t ∈ M ⟹ t ⋅ s = t" by (metis subst_ground_ident)
moreover have "⋀t. t ∈ M ⟹ t ⋅ s ∈ M ⋅⇩s⇩e⇩t s" by (metis imageI)
ultimately show "M ⋅⇩s⇩e⇩t s = M" by (simp add: image_cong)
qed
lemma subst_eqI[intro]: "(⋀t. t ⋅ σ = t ⋅ θ) ⟹ σ = θ"
proof -
assume "⋀t. t ⋅ σ = t ⋅ θ"
hence "⋀v. Var v ⋅ σ = Var v ⋅ θ" by auto
thus "σ = θ" by auto
qed
lemma subst_cong: "⟦σ = σ'; θ = θ'⟧ ⟹ (σ ∘⇩s θ) = (σ' ∘⇩s θ')"
by auto
lemma subst_mgt_bot[simp]: "Var ≼⇩∘ θ"
by simp
lemma subst_mgt_refl[simp]: "θ ≼⇩∘ θ"
by (metis var_comp(1))
lemma subst_mgt_trans: "⟦θ ≼⇩∘ δ; δ ≼⇩∘ σ⟧ ⟹ θ ≼⇩∘ σ"
by (metis subst_compose_assoc)
lemma subst_mgt_comp: "θ ≼⇩∘ θ ∘⇩s δ"
by auto
lemma subst_mgt_comp': "θ ∘⇩s δ ≼⇩∘ σ ⟹ θ ≼⇩∘ σ"
by (metis subst_compose_assoc)
lemma var_self: "(λw. if w = v then Var v else Var w) = Var"
using subst_agreement by auto
lemma var_same[simp]: "Var(v := t) = Var ⟷ t = Var v"
by (intro iffI, metis fun_upd_same, simp add: var_self)
lemma subst_eq_if_eq_vars: "(⋀v. (Var v) ⋅ θ = (Var v) ⋅ σ) ⟹ θ = σ"
by (auto simp add: subst_agreement)
lemma subst_all_empty[simp]: "{} ⋅⇩s⇩e⇩t θ = {}"
by simp
lemma subst_all_insert:"(insert t M) ⋅⇩s⇩e⇩t δ = insert (t ⋅ δ) (M ⋅⇩s⇩e⇩t δ)"
by auto
lemma subst_apply_fv_subset: "fv t ⊆ V ⟹ fv (t ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V)"
by (induct t) auto
lemma subst_apply_fv_empty:
assumes "fv t = {}"
shows "fv (t ⋅ σ) = {}"
using assms subst_apply_fv_subset[of t "{}" σ]
by auto
lemma subst_compose_fv:
assumes "fv (θ x) = {}"
shows "fv ((θ ∘⇩s σ) x) = {}"
using assms subst_apply_fv_empty
unfolding subst_compose_def by fast
lemma subst_compose_fv':
fixes θ σ::"('a,'b) subst"
assumes "y ∈ fv ((θ ∘⇩s σ) x)"
shows "∃z. z ∈ fv (θ x)"
using assms subst_compose_fv
by fast
lemma subst_apply_fv_unfold: "fv (t ⋅ δ) = fv⇩s⇩e⇩t (δ ` fv t)"
by (induct t) auto
lemma subst_apply_fv_unfold': "fv (t ⋅ δ) = (⋃v ∈ fv t. fv (δ v))"
using subst_apply_fv_unfold by simp
lemma subst_apply_fv_union: "fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ) = fv⇩s⇩e⇩t (δ ` (V ∪ fv t))"
proof -
have "fv⇩s⇩e⇩t (δ ` (V ∪ fv t)) = fv⇩s⇩e⇩t (δ ` V) ∪ fv⇩s⇩e⇩t (δ ` fv t)" by auto
thus ?thesis using subst_apply_fv_unfold by metis
qed
lemma subst_elimI[intro]: "(⋀t. v ∉ fv (t ⋅ σ)) ⟹ subst_elim σ v"
by (auto simp add: subst_elim_def)
lemma subst_elimI'[intro]: "(⋀w. v ∉ fv (Var w ⋅ θ)) ⟹ subst_elim θ v"
by (simp add: subst_elim_def subst_apply_fv_unfold')
lemma subst_elimD[dest]: "subst_elim σ v ⟹ v ∉ fv (t ⋅ σ)"
by (auto simp add: subst_elim_def)
lemma subst_elimD'[dest]: "subst_elim σ v ⟹ σ v ≠ Var v"
by (metis subst_elim_def subst_apply_term.simps(1) term.set_intros(3))
lemma subst_elimD''[dest]: "subst_elim σ v ⟹ v ∉ fv (σ w)"
by (metis subst_elim_def subst_apply_term.simps(1))
lemma subst_elim_rm_vars_dest[dest]:
"subst_elim (σ::('a,'b) subst) v ⟹ v ∉ vs ⟹ subst_elim (rm_vars vs σ) v"
proof -
assume assms: "subst_elim σ v" "v ∉ vs"
obtain f::"('a, 'b) subst ⇒ 'b ⇒ 'b" where
"∀σ v. (∃w. v ∈ fv (Var w ⋅ σ)) = (v ∈ fv (Var (f σ v) ⋅ σ))"
by moura
hence *: "∀a σ. a ∈ fv (Var (f σ a) ⋅ σ) ∨ subst_elim σ a" by blast
have "Var (f (rm_vars vs σ) v) ⋅ σ ≠ Var (f (rm_vars vs σ) v) ⋅ rm_vars vs σ
∨ v ∉ fv (Var (f (rm_vars vs σ) v) ⋅ rm_vars vs σ)"
using assms(1) by fastforce
moreover
{ assume "Var (f (rm_vars vs σ) v) ⋅ σ ≠ Var (f (rm_vars vs σ) v) ⋅ rm_vars vs σ"
hence "rm_vars vs σ (f (rm_vars vs σ) v) ≠ σ (f (rm_vars vs σ) v)" by auto
hence "f (rm_vars vs σ) v ∈ vs" by meson
hence ?thesis using * assms(2) by force
}
ultimately show ?thesis using * by blast
qed
lemma occs_subst_elim: "¬Var v ⊏ t ⟹ subst_elim (Var(v := t)) v ∨ (Var(v := t)) = Var"
proof (cases "Var v = t")
assume "Var v ≠ t" "¬Var v ⊏ t"
hence "v ∉ fv t" by (simp add: vars_iff_subterm_or_eq)
thus ?thesis by (auto simp add: subst_remove_var)
qed auto
lemma occs_subst_elim': "¬Var v ⊑ t ⟹ subst_elim (Var(v := t)) v"
proof -
assume "¬Var v ⊑ t"
hence "v ∉ fv t" by (auto simp add: vars_iff_subterm_or_eq)
thus "subst_elim (Var(v := t)) v" by (simp add: subst_elim_def subst_remove_var)
qed
lemma subst_elim_comp: "subst_elim θ v ⟹ subst_elim (δ ∘⇩s θ) v"
by (auto simp add: subst_elim_def)
lemma var_subst_idem: "subst_idem Var"
by (simp add: subst_idem_def)
lemma var_upd_subst_idem:
assumes "¬Var v ⊑ t" shows "subst_idem (Var(v := t))"
unfolding subst_idem_def
proof
let ?θ = "Var(v := t)"
from assms have t_θ_id: "t ⋅ ?θ = t" by blast
fix s show "s ⋅ (?θ ∘⇩s ?θ) = s ⋅ ?θ"
unfolding subst_compose_def
by (induction s, metis t_θ_id fun_upd_def subst_apply_term.simps(1), simp)
qed
subsection ‹Lemmata: Domain and Range of Substitutions›
lemma range_vars_alt_def: "range_vars s ≡ fv⇩s⇩e⇩t (subst_range s)"
unfolding range_vars_def by simp
lemma subst_dom_var_finite[simp]: "finite (subst_domain Var)" by simp
lemma subst_range_Var[simp]: "subst_range Var = {}" by simp
lemma range_vars_Var[simp]: "range_vars Var = {}" by fastforce
lemma finite_subst_img_if_finite_dom: "finite (subst_domain σ) ⟹ finite (range_vars σ)"
unfolding range_vars_alt_def by auto
lemma finite_subst_img_if_finite_dom': "finite (subst_domain σ) ⟹ finite (subst_range σ)"
by auto
lemma subst_img_alt_def: "subst_range s = {t. ∃v. s v = t ∧ t ≠ Var v}"
by (auto simp add: subst_domain_def)
lemma subst_fv_img_alt_def: "range_vars s = (⋃t ∈ {t. ∃v. s v = t ∧ t ≠ Var v}. fv t)"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
lemma subst_domI[intro]: "σ v ≠ Var v ⟹ v ∈ subst_domain σ"
by (simp add: subst_domain_def)
lemma subst_imgI[intro]: "σ v ≠ Var v ⟹ σ v ∈ subst_range σ"
by (simp add: subst_domain_def)
lemma subst_fv_imgI[intro]: "σ v ≠ Var v ⟹ fv (σ v) ⊆ range_vars σ"
unfolding range_vars_alt_def by auto
lemma subst_domain_subst_Fun_single[simp]:
"subst_domain (Var(x := Fun f T)) = {x}" (is "?A = ?B")
unfolding subst_domain_def by simp
lemma subst_range_subst_Fun_single[simp]:
"subst_range (Var(x := Fun f T)) = {Fun f T}" (is "?A = ?B")
by simp
lemma range_vars_subst_Fun_single[simp]:
"range_vars (Var(x := Fun f T)) = fv (Fun f T)"
unfolding range_vars_alt_def by force
lemma var_renaming_is_Fun_iff:
assumes "subst_range δ ⊆ range Var"
shows "is_Fun t = is_Fun (t ⋅ δ)"
proof (cases t)
case (Var x)
hence "∃y. δ x = Var y" using assms by auto
thus ?thesis using Var by auto
qed simp
lemma subst_fv_dom_img_subset: "fv t ⊆ subst_domain θ ⟹ fv (t ⋅ θ) ⊆ range_vars θ"
unfolding range_vars_alt_def by (induct t) auto
lemma subst_fv_dom_img_subset_set: "fv⇩s⇩e⇩t M ⊆ subst_domain θ ⟹ fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ) ⊆ range_vars θ"
proof -
assume assms: "fv⇩s⇩e⇩t M ⊆ subst_domain θ"
obtain f::"'a set ⇒ (('b, 'a) term ⇒ 'a set) ⇒ ('b, 'a) terms ⇒ ('b, 'a) term" where
"∀x y z. (∃v. v ∈ z ∧ ¬ y v ⊆ x) ⟷ (f x y z ∈ z ∧ ¬ y (f x y z) ⊆ x)"
by moura
hence *:
"∀T g A. (¬ ⋃ (g ` T) ⊆ A ∨ (∀t. t ∉ T ∨ g t ⊆ A)) ∧
(⋃ (g ` T) ⊆ A ∨ f A g T ∈ T ∧ ¬ g (f A g T) ⊆ A)"
by (metis (no_types) SUP_le_iff)
hence **: "∀t. t ∉ M ∨ fv t ⊆ subst_domain θ" by (metis (no_types) assms fv⇩s⇩e⇩t.simps)
have "∀t::('b, 'a) term. ∀f T. t ∉ f ` T ∨ (∃t'::('b, 'a) term. t = f t' ∧ t' ∈ T)" by blast
hence "f (range_vars θ) fv (M ⋅⇩s⇩e⇩t θ) ∉ M ⋅⇩s⇩e⇩t θ ∨
fv (f (range_vars θ) fv (M ⋅⇩s⇩e⇩t θ)) ⊆ range_vars θ"
by (metis (full_types) ** subst_fv_dom_img_subset)
thus ?thesis by (metis (no_types) * fv⇩s⇩e⇩t.simps)
qed
lemma subst_fv_dom_ground_if_ground_img:
assumes "fv t ⊆ subst_domain s" "ground (subst_range s)"
shows "fv (t ⋅ s) = {}"
using subst_fv_dom_img_subset[OF assms(1)] assms(2) by force
lemma subst_fv_dom_ground_if_ground_img':
assumes "fv t ⊆ subst_domain s" "⋀x. x ∈ subst_domain s ⟹ fv (s x) = {}"
shows "fv (t ⋅ s) = {}"
using subst_fv_dom_ground_if_ground_img[OF assms(1)] assms(2) by auto
lemma subst_fv_unfold: "fv (t ⋅ s) = (fv t - subst_domain s) ∪ fv⇩s⇩e⇩t (s ` (fv t ∩ subst_domain s))"
proof (induction t)
case (Var v) thus ?case
proof (cases "v ∈ subst_domain s")
case True thus ?thesis by auto
next
case False
hence "fv (Var v ⋅ s) = {v}" "fv (Var v) ∩ subst_domain s = {}" by auto
thus ?thesis by auto
qed
next
case Fun thus ?case by auto
qed
lemma subst_fv_unfold_ground_img: "range_vars s = {} ⟹ fv (t ⋅ s) = fv t - subst_domain s"
using subst_fv_unfold[of t s] unfolding range_vars_alt_def by auto
lemma subst_img_update:
"⟦σ v = Var v; t ≠ Var v⟧ ⟹ range_vars (σ(v := t)) = range_vars σ ∪ fv t"
proof -
assume "σ v = Var v" "t ≠ Var v"
hence "(⋃s ∈ {s. ∃w. (σ(v := t)) w = s ∧ s ≠ Var w}. fv s) = fv t ∪ range_vars σ"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
thus "range_vars (σ(v := t)) = range_vars σ ∪ fv t"
by (metis Un_commute subst_fv_img_alt_def)
qed
lemma subst_dom_update1: "v ∉ subst_domain σ ⟹ subst_domain (σ(v := Var v)) = subst_domain σ"
by (auto simp add: subst_domain_def)
lemma subst_dom_update2: "t ≠ Var v ⟹ subst_domain (σ(v := t)) = insert v (subst_domain σ)"
by (auto simp add: subst_domain_def)
lemma subst_dom_update3: "t = Var v ⟹ subst_domain (σ(v := t)) = subst_domain σ - {v}"
by (auto simp add: subst_domain_def)
lemma var_not_in_subst_dom[elim]: "v ∉ subst_domain s ⟹ s v = Var v"
by (simp add: subst_domain_def)
lemma subst_dom_vars_in_subst[elim]: "v ∈ subst_domain s ⟹ s v ≠ Var v"
by (simp add: subst_domain_def)
lemma subst_not_dom_fixed: "⟦v ∈ fv t; v ∉ subst_domain s⟧ ⟹ v ∈ fv (t ⋅ s)" by (induct t) auto
lemma subst_not_img_fixed: "⟦v ∈ fv (t ⋅ s); v ∉ range_vars s⟧ ⟹ v ∈ fv t"
unfolding range_vars_alt_def by (induct t) force+
lemma ground_range_vars[intro]: "ground (subst_range s) ⟹ range_vars s = {}"
unfolding range_vars_alt_def by metis
lemma ground_subst_no_var[intro]: "ground (subst_range s) ⟹ x ∉ range_vars s"
using ground_range_vars[of s] by blast
lemma ground_img_obtain_fun:
assumes "ground (subst_range s)" "x ∈ subst_domain s"
obtains f T where "s x = Fun f T" "Fun f T ∈ subst_range s" "fv (Fun f T) = {}"
proof -
from assms(2) obtain t where t: "s x = t" "t ∈ subst_range s" by moura
hence "fv t = {}" using assms(1) by auto
thus ?thesis using t that by (cases t) simp_all
qed
lemma ground_term_subst_domain_fv_subset:
"fv (t ⋅ δ) = {} ⟹ fv t ⊆ subst_domain δ"
by (induct t) auto
lemma ground_subst_range_empty_fv:
"ground (subst_range θ) ⟹ x ∈ subst_domain θ ⟹ fv (θ x) = {}"
by simp
lemma subst_Var_notin_img: "x ∉ range_vars s ⟹ t ⋅ s = Var x ⟹ t = Var x"
using subst_not_img_fixed[of x t s] by (induct t) auto
lemma fv_in_subst_img: "⟦s v = t; t ≠ Var v⟧ ⟹ fv t ⊆ range_vars s"
unfolding range_vars_alt_def by auto
lemma empty_dom_iff_empty_subst: "subst_domain θ = {} ⟷ θ = Var" by auto
lemma subst_dom_cong: "(⋀v t. θ v = t ⟹ δ v = t) ⟹ subst_domain θ ⊆ subst_domain δ"
by (auto simp add: subst_domain_def)
lemma subst_img_cong: "(⋀v t. θ v = t ⟹ δ v = t) ⟹ range_vars θ ⊆ range_vars δ"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
lemma subst_dom_elim: "subst_domain s ∩ range_vars s = {} ⟹ fv (t ⋅ s) ∩ subst_domain s = {}"
proof (induction t)
case (Var v) thus ?case
using fv_in_subst_img[of s]
by (cases "s v = Var v") (auto simp add: subst_domain_def)
next
case Fun thus ?case by auto
qed
lemma subst_dom_insert_finite: "finite (subst_domain s) = finite (subst_domain (s(v := t)))"
proof
assume "finite (subst_domain s)"
have "subst_domain (s(v := t)) ⊆ insert v (subst_domain s)" by (auto simp add: subst_domain_def)
thus "finite (subst_domain (s(v := t)))"
by (meson ‹finite (subst_domain s)› finite_insert rev_finite_subset)
next
assume *: "finite (subst_domain (s(v := t)))"
hence "finite (insert v (subst_domain s))"
proof (cases "t = Var v")
case True
hence "finite (subst_domain s - {v})" by (metis * subst_dom_update3)
thus ?thesis by simp
qed (metis * subst_dom_update2[of t v s])
thus "finite (subst_domain s)" by simp
qed
lemma trm_subst_disj: "t ⋅ θ = t ⟹ fv t ∩ subst_domain θ = {}"
proof (induction t)
case (Fun f X)
hence "map (λx. x ⋅ θ) X = X" by simp
hence "⋀x. x ∈ set X ⟹ x ⋅ θ = x" using map_eq_conv by fastforce
thus ?case using Fun.IH by auto
qed (simp add: subst_domain_def)
lemma trm_subst_ident[intro]: "fv t ∩ subst_domain θ = {} ⟹ t ⋅ θ = t"
proof -
assume "fv t ∩ subst_domain θ = {}"
hence "∀v ∈ fv t. ∀w ∈ subst_domain θ. v ≠ w" by auto
thus ?thesis
by (metis subst_agreement subst_apply_term.simps(1) subst_apply_term_empty subst_domI)
qed
lemma trm_subst_ident'[intro]: "v ∉ subst_domain θ ⟹ (Var v) ⋅ θ = Var v"
using trm_subst_ident by (simp add: subst_domain_def)
lemma trm_subst_ident''[intro]: "(⋀x. x ∈ fv t ⟹ θ x = Var x) ⟹ t ⋅ θ = t"
proof -
assume "⋀x. x ∈ fv t ⟹ θ x = Var x"
hence "fv t ∩ subst_domain θ = {}" by (auto simp add: subst_domain_def)
thus ?thesis using trm_subst_ident by auto
qed
lemma set_subst_ident: "fv⇩s⇩e⇩t M ∩ subst_domain θ = {} ⟹ M ⋅⇩s⇩e⇩t θ = M"
proof -
assume "fv⇩s⇩e⇩t M ∩ subst_domain θ = {}"
hence "∀t ∈ M. t ⋅ θ = t" by auto
thus ?thesis by force
qed
lemma trm_subst_ident_subterms[intro]:
"fv t ∩ subst_domain θ = {} ⟹ subterms t ⋅⇩s⇩e⇩t θ = subterms t"
using set_subst_ident[of "subterms t" θ] fv_subterms[of t] by simp
lemma trm_subst_ident_subterms'[intro]:
"v ∉ fv t ⟹ subterms t ⋅⇩s⇩e⇩t Var(v := s) = subterms t"
using trm_subst_ident_subterms[of t "Var(v := s)"]
by (meson subst_no_occs trm_subst_disj vars_iff_subtermeq)
lemma const_mem_subst_cases:
assumes "Fun c [] ∈ M ⋅⇩s⇩e⇩t θ"
shows "Fun c [] ∈ M ∨ Fun c [] ∈ θ ` fv⇩s⇩e⇩t M"
proof -
obtain m where m: "m ∈ M" "m ⋅ θ = Fun c []" using assms by auto
thus ?thesis by (cases m) force+
qed
lemma const_mem_subst_cases':
assumes "Fun c [] ∈ M ⋅⇩s⇩e⇩t θ"
shows "Fun c [] ∈ M ∨ Fun c [] ∈ subst_range θ"
using const_mem_subst_cases[OF assms] by force
lemma fv_subterms_substI[intro]: "y ∈ fv t ⟹ θ y ∈ subterms t ⋅⇩s⇩e⇩t θ"
using image_iff vars_iff_subtermeq by fastforce
lemma fv_subterms_subst_eq[simp]: "fv⇩s⇩e⇩t (subterms (t ⋅ θ)) = fv⇩s⇩e⇩t (subterms t ⋅⇩s⇩e⇩t θ)"
using fv_subterms by (induct t) force+
lemma fv_subterms_set_subst: "fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ) = fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ))"
using fv_subterms_subst_eq[of _ θ] by auto
lemma fv_subterms_set_subst': "fv⇩s⇩e⇩t (subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ) = fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
using fv_subterms_set[of "M ⋅⇩s⇩e⇩t θ"] fv_subterms_set_subst[of θ M] by simp
lemma fv_subst_subset: "x ∈ fv t ⟹ fv (θ x) ⊆ fv (t ⋅ θ)"
by (metis fv_subset image_eqI subst_apply_fv_unfold)
lemma fv_subst_subset': "fv s ⊆ fv t ⟹ fv (s ⋅ θ) ⊆ fv (t ⋅ θ)"
using fv_subst_subset by (induct s) force+
lemma fv_subst_obtain_var:
fixes δ::"('a,'b) subst"
assumes "x ∈ fv (t ⋅ δ)"
shows "∃y ∈ fv t. x ∈ fv (δ y)"
using assms by (induct t) force+
lemma set_subst_all_ident: "fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ) ∩ subst_domain δ = {} ⟹ M ⋅⇩s⇩e⇩t (θ ∘⇩s δ) = M ⋅⇩s⇩e⇩t θ"
by (metis set_subst_ident subst_comp_all)
lemma subterms_subst:
"subterms (t ⋅ d) = (subterms t ⋅⇩s⇩e⇩t d) ∪ subterms⇩s⇩e⇩t (d ` (fv t ∩ subst_domain d))"
by (induct t) (auto simp add: subst_domain_def)
lemma subterms_subst':
fixes θ::"('a,'b) subst"
assumes "∀x ∈ fv t. (∃f. θ x = Fun f []) ∨ (∃y. θ x = Var y)"
shows "subterms (t ⋅ θ) = subterms t ⋅⇩s⇩e⇩t θ"
using assms
proof (induction t)
case (Var x) thus ?case
proof (cases "x ∈ subst_domain θ")
case True
hence "(∃f. θ x = Fun f []) ∨ (∃y. θ x = Var y)" using Var by simp
hence "subterms (θ x) = {θ x}" by auto
thus ?thesis by simp
qed auto
qed auto
lemma subterms_subst'':
fixes θ::"('a,'b) subst"
assumes "∀x ∈ fv⇩s⇩e⇩t M. (∃f. θ x = Fun f []) ∨ (∃y. θ x = Var y)"
shows "subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ) = subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ"
using subterms_subst'[of _ θ] assms by auto
lemma subterms_subst_subterm:
fixes θ::"('a,'b) subst"
assumes "∀x ∈ fv a. (∃f. θ x = Fun f []) ∨ (∃y. θ x = Var y)"
and "b ∈ subterms (a ⋅ θ)"
shows "∃c ∈ subterms a. c ⋅ θ = b"
using subterms_subst'[OF assms(1)] assms(2) by auto
lemma subterms_subst_subset: "subterms t ⋅⇩s⇩e⇩t σ ⊆ subterms (t ⋅ σ)"
by (induct t) auto
lemma subterms_subst_subset': "subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t σ ⊆ subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t σ)"
using subterms_subst_subset by fast
lemma subterms⇩s⇩e⇩t_subst:
fixes θ::"('a,'b) subst"
assumes "t ∈ subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
shows "t ∈ subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ ∨ (∃x ∈ fv⇩s⇩e⇩t M. t ∈ subterms (θ x))"
using assms subterms_subst[of _ θ] by auto
lemma rm_vars_dom: "subst_domain (rm_vars V s) = subst_domain s - V"
by (auto simp add: subst_domain_def)
lemma rm_vars_dom_subset: "subst_domain (rm_vars V s) ⊆ subst_domain s"
by (auto simp add: subst_domain_def)
lemma rm_vars_dom_eq':
"subst_domain (rm_vars (UNIV - V) s) = subst_domain s ∩ V"
using rm_vars_dom[of "UNIV - V" s] by blast
lemma rm_vars_img: "subst_range (rm_vars V s) = s ` subst_domain (rm_vars V s)"
by (auto simp add: subst_domain_def)
lemma rm_vars_img_subset: "subst_range (rm_vars V s) ⊆ subst_range s"
by (auto simp add: subst_domain_def)
lemma rm_vars_img_fv_subset: "range_vars (rm_vars V s) ⊆ range_vars s"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
lemma rm_vars_fv_obtain:
assumes "x ∈ fv (t ⋅ rm_vars X θ) - X"
shows "∃y ∈ fv t - X. x ∈ fv (rm_vars X θ y)"
using assms by (induct t) (fastforce, force)
lemma rm_vars_apply: "v ∈ subst_domain (rm_vars V s) ⟹ (rm_vars V s) v = s v"
by (auto simp add: subst_domain_def)
lemma rm_vars_apply': "subst_domain δ ∩ vs = {} ⟹ rm_vars vs δ = δ"
by force
lemma rm_vars_ident: "fv t ∩ vs = {} ⟹ t ⋅ (rm_vars vs θ) = t ⋅ θ"
by (induct t) auto
lemma rm_vars_fv_subset: "fv (t ⋅ rm_vars X θ) ⊆ fv t ∪ fv (t ⋅ θ)"
by (induct t) auto
lemma rm_vars_fv_disj:
assumes "fv t ∩ X = {}" "fv (t ⋅ θ) ∩ X = {}"
shows "fv (t ⋅ rm_vars X θ) ∩ X = {}"
using rm_vars_ident[OF assms(1)] assms(2) by auto
lemma rm_vars_ground_supports:
assumes "ground (subst_range θ)"
shows "rm_vars X θ supports θ"
proof
fix x
have *: "ground (subst_range (rm_vars X θ))"
using rm_vars_img_subset[of X θ] assms
by (auto simp add: subst_domain_def)
show "rm_vars X θ x ⋅ θ = θ x "
proof (cases "x ∈ subst_domain (rm_vars X θ)")
case True
hence "fv (rm_vars X θ x) = {}" using * by auto
thus ?thesis using True by auto
qed (simp add: subst_domain_def)
qed
lemma rm_vars_split:
assumes "ground (subst_range θ)"
shows "θ = rm_vars X θ ∘⇩s rm_vars (subst_domain θ - X) θ"
proof -
let ?s1 = "rm_vars X θ"
let ?s2 = "rm_vars (subst_domain θ - X) θ"
have doms: "subst_domain ?s1 ⊆ subst_domain θ" "subst_domain ?s2 ⊆ subst_domain θ"
by (auto simp add: subst_domain_def)
{ fix x assume "x ∉ subst_domain θ"
hence "θ x = Var x" "?s1 x = Var x" "?s2 x = Var x" using doms by auto
hence "θ x = (?s1 ∘⇩s ?s2) x" by (simp add: subst_compose_def)
} moreover {
fix x assume "x ∈ subst_domain θ" "x ∈ X"
hence "?s1 x = Var x" "?s2 x = θ x" using doms by auto
hence "θ x = (?s1 ∘⇩s ?s2) x" by (simp add: subst_compose_def)
} moreover {
fix x assume "x ∈ subst_domain θ" "x ∉ X"
hence "?s1 x = θ x" "fv (θ x) = {}" using assms doms by auto
hence "θ x = (?s1 ∘⇩s ?s2) x" by (simp add: subst_compose subst_ground_ident)
} ultimately show ?thesis by blast
qed
lemma rm_vars_fv_img_disj:
assumes "fv t ∩ X = {}" "X ∩ range_vars θ = {}"
shows "fv (t ⋅ rm_vars X θ) ∩ X = {}"
using assms
proof (induction t)
case (Var x)
hence *: "(rm_vars X θ) x = θ x" by auto
show ?case
proof (cases "x ∈ subst_domain θ")
case True
hence "θ x ∈ subst_range θ" by auto
hence "fv (θ x) ∩ X = {}" using Var.prems(2) unfolding range_vars_alt_def by fastforce
thus ?thesis using * by auto
next
case False thus ?thesis using Var.prems(1) by auto
qed
next
case Fun thus ?case by auto
qed
lemma subst_apply_dom_ident: "t ⋅ θ = t ⟹ subst_domain δ ⊆ subst_domain θ ⟹ t ⋅ δ = t"
proof (induction t)
case (Fun f T) thus ?case by (induct T) auto
qed (auto simp add: subst_domain_def)
lemma rm_vars_subst_apply_ident:
assumes "t ⋅ θ = t"
shows "t ⋅ (rm_vars vs θ) = t"
using rm_vars_dom[of vs θ] subst_apply_dom_ident[OF assms, of "rm_vars vs θ"] by auto
lemma rm_vars_subst_eq:
"t ⋅ δ = t ⋅ rm_vars (subst_domain δ - subst_domain δ ∩ fv t) δ"
by (auto intro: term_subst_eq)
lemma rm_vars_subst_eq':
"t ⋅ δ = t ⋅ rm_vars (UNIV - fv t) δ"
by (auto intro: term_subst_eq)
lemma rm_vars_comp:
assumes "range_vars δ ∩ vs = {}"
shows "t ⋅ rm_vars vs (δ ∘⇩s θ) = t ⋅ (rm_vars vs δ ∘⇩s rm_vars vs θ)"
using assms
proof (induction t)
case (Var x) thus ?case
proof (cases "x ∈ vs")
case True thus ?thesis using Var by auto
next
case False
have "subst_domain (rm_vars vs θ) ∩ vs = {}" by (auto simp add: subst_domain_def)
moreover have "fv (δ x) ∩ vs = {}"
using Var False unfolding range_vars_alt_def by force
ultimately have "δ x ⋅ (rm_vars vs θ) = δ x ⋅ θ"
using rm_vars_ident by (simp add: subst_domain_def)
moreover have "(rm_vars vs (δ ∘⇩s θ)) x = (δ ∘⇩s θ) x" by (metis False)
ultimately show ?thesis using subst_compose by auto
qed
next
case Fun thus ?case by auto
qed
lemma rm_vars_fv⇩s⇩e⇩t_subst:
assumes "x ∈ fv⇩s⇩e⇩t (rm_vars X θ ` Y)"
shows "x ∈ fv⇩s⇩e⇩t (θ ` Y) ∨ x ∈ X"
using assms by auto
lemma disj_dom_img_var_notin:
assumes "subst_domain θ ∩ range_vars θ = {}" "θ v = t" "t ≠ Var v"
shows "v ∉ fv t" "∀v ∈ fv (t ⋅ θ). v ∉ subst_domain θ"
proof -
have "v ∈ subst_domain θ" "fv t ⊆ range_vars θ"
using fv_in_subst_img[of θ v t, OF assms(2)] assms(2,3)
by (auto simp add: subst_domain_def)
thus "v ∉ fv t" using assms(1) by auto
have *: "fv t ∩ subst_domain θ = {}"
using assms(1) ‹fv t ⊆ range_vars θ›
by auto
hence "t ⋅ θ = t" by blast
thus "∀v ∈ fv (t ⋅ θ). v ∉ subst_domain θ" using * by auto
qed
lemma subst_sends_dom_to_img: "v ∈ subst_domain θ ⟹ fv (Var v ⋅ θ) ⊆ range_vars θ"
unfolding range_vars_alt_def by auto
lemma subst_sends_fv_to_img: "fv (t ⋅ s) ⊆ fv t ∪ range_vars s"
proof (induction t)
case (Var v) thus ?case
proof (cases "Var v ⋅ s = Var v")
case True thus ?thesis by simp
next
case False
hence "v ∈ subst_domain s" by (meson trm_subst_ident')
hence "fv (Var v ⋅ s) ⊆ range_vars s"
using subst_sends_dom_to_img by simp
thus ?thesis by auto
qed
next
case Fun thus ?case by auto
qed
lemma ident_comp_subst_trm_if_disj:
assumes "subst_domain σ ∩ range_vars θ = {}" "v ∈ subst_domain θ"
shows "(θ ∘⇩s σ) v = θ v"
proof -
from assms have " subst_domain σ ∩ fv (θ v) = {}"
using fv_in_subst_img unfolding range_vars_alt_def by auto
thus "(θ ∘⇩s σ) v = θ v" unfolding subst_compose_def by blast
qed
lemma ident_comp_subst_trm_if_disj': "fv (θ v) ∩ subst_domain σ = {} ⟹ (θ ∘⇩s σ) v = θ v"
unfolding subst_compose_def by blast
lemma subst_idemI[intro]: "subst_domain σ ∩ range_vars σ = {} ⟹ subst_idem σ"
using ident_comp_subst_trm_if_disj[of σ σ]
var_not_in_subst_dom[of _ σ]
subst_eq_if_eq_vars[of σ]
by (metis subst_idem_def subst_compose_def var_comp(2))
lemma subst_idemI'[intro]: "ground (subst_range σ) ⟹ subst_idem σ"
proof (intro subst_idemI)
assume "ground (subst_range σ)"
hence "range_vars σ = {}" by (metis ground_range_vars)
thus "subst_domain σ ∩ range_vars σ = {}" by blast
qed
lemma subst_idemE: "subst_idem σ ⟹ subst_domain σ ∩ range_vars σ = {}"
proof -
assume "subst_idem σ"
hence "⋀v. fv (σ v) ∩ subst_domain σ = {}"
unfolding subst_idem_def subst_compose_def by (metis trm_subst_disj)
thus ?thesis
unfolding range_vars_alt_def by auto
qed
lemma subst_idem_rm_vars: "subst_idem θ ⟹ subst_idem (rm_vars X θ)"
proof -
assume "subst_idem θ"
hence "subst_domain θ ∩ range_vars θ = {}" by (metis subst_idemE)
moreover have
"subst_domain (rm_vars X θ) ⊆ subst_domain θ"
"range_vars (rm_vars X θ) ⊆ range_vars θ"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
ultimately show ?thesis by blast
qed
lemma subst_fv_bounded_if_img_bounded: "range_vars θ ⊆ fv t ∪ V ⟹ fv (t ⋅ θ) ⊆ fv t ∪ V"
proof (induction t)
case (Var v) thus ?case unfolding range_vars_alt_def by (cases "θ v = Var v") auto
qed (metis (no_types, lifting) Un_assoc Un_commute subst_sends_fv_to_img sup.absorb_iff2)
lemma subst_fv_bound_singleton: "fv (t ⋅ Var(v := t')) ⊆ fv t ∪ fv t'"
using subst_fv_bounded_if_img_bounded[of "Var(v := t')" t "fv t'"]
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
lemma subst_fv_bounded_if_img_bounded':
assumes "range_vars θ ⊆ fv⇩s⇩e⇩t M"
shows "fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ) ⊆ fv⇩s⇩e⇩t M"
proof
fix v assume *: "v ∈ fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
obtain t where t: "t ∈ M" "t ⋅ θ ∈ M ⋅⇩s⇩e⇩t θ" "v ∈ fv (t ⋅ θ)"
proof -
assume **: "⋀t. ⟦t ∈ M; t ⋅ θ ∈ M ⋅⇩s⇩e⇩t θ; v ∈ fv (t ⋅ θ)⟧ ⟹ thesis"
have "v ∈ ⋃ (fv ` ((λt. t ⋅ θ) ` M))" using * by (metis fv⇩s⇩e⇩t.simps)
hence "∃t. t ∈ M ∧ v ∈ fv (t ⋅ θ)" by blast
thus ?thesis using ** imageI by blast
qed
from ‹t ∈ M› obtain M' where "t ∉ M'" "M = insert t M'" by (meson Set.set_insert)
hence "fv⇩s⇩e⇩t M = fv t ∪ fv⇩s⇩e⇩t M'" by simp
hence "fv (t ⋅ θ) ⊆ fv⇩s⇩e⇩t M" using subst_fv_bounded_if_img_bounded assms by simp
thus "v ∈ fv⇩s⇩e⇩t M" using assms ‹v ∈ fv (t ⋅ θ)› by auto
qed
lemma ground_img_if_ground_subst: "(⋀v t. s v = t ⟹ fv t = {}) ⟹ range_vars s = {}"
unfolding range_vars_alt_def by auto
lemma ground_subst_fv_subset: "ground (subst_range θ) ⟹ fv (t ⋅ θ) ⊆ fv t"
using subst_fv_bounded_if_img_bounded[of θ]
unfolding range_vars_alt_def by force
lemma ground_subst_fv_subset': "ground (subst_range θ) ⟹ fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ) ⊆ fv⇩s⇩e⇩t M"
using subst_fv_bounded_if_img_bounded'[of θ M]
unfolding range_vars_alt_def by auto
lemma subst_to_var_is_var[elim]: "t ⋅ s = Var v ⟹ ∃w. t = Var w"
using subst_apply_term.elims by blast
lemma subst_dom_comp_inI:
assumes "y ∉ subst_domain σ"
and "y ∈ subst_domain δ"
shows "y ∈ subst_domain (σ ∘⇩s δ)"
using assms subst_domain_subst_compose[of σ δ] by blast
lemma subst_comp_notin_dom_eq:
"x ∉ subst_domain θ1 ⟹ (θ1 ∘⇩s θ2) x = θ2 x"
unfolding subst_compose_def by fastforce
lemma subst_dom_comp_eq:
assumes "subst_domain θ ∩ range_vars σ = {}"
shows "subst_domain (θ ∘⇩s σ) = subst_domain θ ∪ subst_domain σ"
proof (rule ccontr)
assume "subst_domain (θ ∘⇩s σ) ≠ subst_domain θ ∪ subst_domain σ"
hence "subst_domain (θ ∘⇩s σ) ⊂ subst_domain θ ∪ subst_domain σ"
using subst_domain_compose[of θ σ] by (simp add: subst_domain_def)
then obtain v where "v ∉ subst_domain (θ ∘⇩s σ)" "v ∈ subst_domain θ ∪ subst_domain σ" by auto
hence v_in_some_subst: "θ v ≠ Var v ∨ σ v ≠ Var v" and "θ v ⋅ σ = Var v"
unfolding subst_compose_def by (auto simp add: subst_domain_def)
then obtain w where "θ v = Var w" using subst_to_var_is_var by fastforce
show False
proof (cases "v = w")
case True
hence "θ v = Var v" using ‹θ v = Var w› by simp
hence "σ v ≠ Var v" using v_in_some_subst by simp
thus False using ‹θ v = Var v› ‹θ v ⋅ σ = Var v› by simp
next
case False
hence "v ∈ subst_domain θ" using v_in_some_subst ‹θ v ⋅ σ = Var v› by auto
hence "v ∉ range_vars σ" using assms by auto
moreover have "σ w = Var v" using ‹θ v ⋅ σ = Var v› ‹θ v = Var w› by simp
hence "v ∈ range_vars σ" using ‹v ≠ w› subst_fv_imgI[of σ w] by simp
ultimately show False ..
qed
qed
lemma subst_img_comp_subset[simp]:
"range_vars (θ1 ∘⇩s θ2) ⊆ range_vars θ1 ∪ range_vars θ2"
proof
let ?img = "range_vars"
fix x assume "x ∈ ?img (θ1 ∘⇩s θ2)"
then obtain v t where vt: "x ∈ fv t" "t = (θ1 ∘⇩s θ2) v" "t ≠ Var v"
unfolding range_vars_alt_def subst_compose_def by (auto simp add: subst_domain_def)
{ assume "x ∉ ?img θ1" hence "x ∈ ?img θ2"
by (metis (no_types, hide_lams) fv_in_subst_img Un_iff subst_compose_def
vt subsetCE subst_apply_term.simps(1) subst_sends_fv_to_img)
}
thus "x ∈ ?img θ1 ∪ ?img θ2" by auto
qed
lemma subst_img_comp_subset':
assumes "t ∈ subst_range (θ1 ∘⇩s θ2)"
shows "t ∈ subst_range θ2 ∨ (∃t' ∈ subst_range θ1. t = t' ⋅ θ2)"
proof -
obtain x where x: "x ∈ subst_domain (θ1 ∘⇩s θ2)" "(θ1 ∘⇩s θ2) x = t" "t ≠ Var x"
using assms by (auto simp add: subst_domain_def)
{ assume "x ∉ subst_domain θ1"
hence "(θ1 ∘⇩s θ2) x = θ2 x" unfolding subst_compose_def by auto
hence ?thesis using x by auto
} moreover {
assume "x ∈ subst_domain θ1" hence ?thesis using subst_compose x(2) by fastforce
} ultimately show ?thesis by metis
qed
lemma subst_img_comp_subset'':
"subterms⇩s⇩e⇩t (subst_range (θ1 ∘⇩s θ2)) ⊆
subterms⇩s⇩e⇩t (subst_range θ2) ∪ ((subterms⇩s⇩e⇩t (subst_range θ1)) ⋅⇩s⇩e⇩t θ2)"
proof
fix t assume "t ∈ subterms⇩s⇩e⇩t (subst_range (θ1 ∘⇩s θ2))"
then obtain x where x: "x ∈ subst_domain (θ1 ∘⇩s θ2)" "t ∈ subterms ((θ1 ∘⇩s θ2) x)"
by auto
show "t ∈ subterms⇩s⇩e⇩t (subst_range θ2) ∪ (subterms⇩s⇩e⇩t (subst_range θ1) ⋅⇩s⇩e⇩t θ2)"
proof (cases "x ∈ subst_domain θ1")
case True thus ?thesis
using subst_compose[of θ1 θ2] x(2) subterms_subst
by fastforce
next
case False
hence "(θ1 ∘⇩s θ2) x = θ2 x" unfolding subst_compose_def by auto
thus ?thesis using x by (auto simp add: subst_domain_def)
qed
qed
lemma subst_img_comp_subset''':
"subterms⇩s⇩e⇩t (subst_range (θ1 ∘⇩s θ2)) - range Var ⊆
subterms⇩s⇩e⇩t (subst_range θ2) - range Var ∪ ((subterms⇩s⇩e⇩t (subst_range θ1) - range Var) ⋅⇩s⇩e⇩t θ2)"
proof
fix t assume t: "t ∈ subterms⇩s⇩e⇩t (subst_range (θ1 ∘⇩s θ2)) - range Var"
then obtain f T where fT: "t = Fun f T" by (cases t) simp_all
then obtain x where x: "x ∈ subst_domain (θ1 ∘⇩s θ2)" "Fun f T ∈ subterms ((θ1 ∘⇩s θ2) x)"
using t by auto
have "Fun f T ∈ subterms⇩s⇩e⇩t (subst_range θ2) ∪ (subterms⇩s⇩e⇩t (subst_range θ1) - range Var ⋅⇩s⇩e⇩t θ2)"
proof (cases "x ∈ subst_domain θ1")
case True
hence "Fun f T ∈ (subterms⇩s⇩e⇩t (subst_range θ2)) ∪ (subterms (θ1 x) ⋅⇩s⇩e⇩t θ2)"
using x(2) subterms_subst[of "θ1 x" θ2]
unfolding subst_compose[of θ1 θ2 x] by auto
moreover have ?thesis when *: "Fun f T ∈ subterms (θ1 x) ⋅⇩s⇩e⇩t θ2"
proof -
obtain s where s: "s ∈ subterms (θ1 x)" "Fun f T = s ⋅ θ2" using * by moura
show ?thesis
proof (cases s)
case (Var y)
hence "Fun f T ∈ subst_range θ2" using s by force
thus ?thesis by blast
next
case (Fun g S)
hence "Fun f T ∈ (subterms (θ1 x) - range Var) ⋅⇩s⇩e⇩t θ2" using s by blast
thus ?thesis using True by auto
qed
qed
ultimately show ?thesis by blast
next
case False
hence "(θ1 ∘⇩s θ2) x = θ2 x" unfolding subst_compose_def by auto
thus ?thesis using x by (auto simp add: subst_domain_def)
qed
thus "t ∈ subterms⇩s⇩e⇩t (subst_range θ2) - range Var ∪
(subterms⇩s⇩e⇩t (subst_range θ1) - range Var ⋅⇩s⇩e⇩t θ2)"
using fT by auto
qed
lemma subst_img_comp_subset_const:
assumes "Fun c [] ∈ subst_range (θ1 ∘⇩s θ2)"
shows "Fun c [] ∈ subst_range θ2 ∨ Fun c [] ∈ subst_range θ1 ∨
(∃x. Var x ∈ subst_range θ1 ∧ θ2 x = Fun c [])"
proof (cases "Fun c [] ∈ subst_range θ2")
case False
then obtain t where t: "t ∈ subst_range θ1" "Fun c [] = t ⋅ θ2"
using subst_img_comp_subset'[OF assms] by auto
thus ?thesis by (cases t) auto
qed (simp add: subst_img_comp_subset'[OF assms])
lemma subst_img_comp_subset_const':
fixes δ τ::"('f,'v) subst"
assumes "(δ ∘⇩s τ) x = Fun c []"
shows "δ x = Fun c [] ∨ (∃z. δ x = Var z ∧ τ z = Fun c [])"
proof (cases "δ x = Fun c []")
case False
then obtain t where "δ x = t" "t ⋅ τ = Fun c []" using assms unfolding subst_compose_def by auto
thus ?thesis by (cases t) auto
qed simp
lemma subst_img_comp_subset_ground:
assumes "ground (subst_range θ1)"
shows "subst_range (θ1 ∘⇩s θ2) ⊆ subst_range θ1 ∪ subst_range θ2"
proof
fix t assume t: "t ∈ subst_range (θ1 ∘⇩s θ2)"
then obtain x where x: "x ∈ subst_domain (θ1 ∘⇩s θ2)" "t = (θ1 ∘⇩s θ2) x" by auto
show "t ∈ subst_range θ1 ∪ subst_range θ2"
proof (cases "x ∈ subst_domain θ1")
case True
hence "fv (θ1 x) = {}" using assms ground_subst_range_empty_fv by fast
hence "t = θ1 x" using x(2) unfolding subst_compose_def by blast
thus ?thesis using True by simp
next
case False
hence "t = θ2 x" "x ∈ subst_domain θ2"
using x subst_domain_compose[of θ1 θ2]
by (metis subst_comp_notin_dom_eq, blast)
thus ?thesis using x by simp
qed
qed
lemma subst_fv_dom_img_single:
assumes "v ∉ fv t" "σ v = t" "⋀w. v ≠ w ⟹ σ w = Var w"
shows "subst_domain σ = {v}" "range_vars σ = fv t"
proof -
show "subst_domain σ = {v}" using assms by (fastforce simp add: subst_domain_def)
have "fv t ⊆ range_vars σ" by (metis fv_in_subst_img assms(1,2) vars_iff_subterm_or_eq)
moreover have "⋀v. σ v ≠ Var v ⟹ σ v = t" using assms by fastforce
ultimately show "range_vars σ = fv t"
unfolding range_vars_alt_def
by (auto simp add: subst_domain_def)
qed
lemma subst_comp_upd1:
"θ(v := t) ∘⇩s σ = (θ ∘⇩s σ)(v := t ⋅ σ)"
unfolding subst_compose_def by auto
lemma subst_comp_upd2:
assumes "v ∉ subst_domain s" "v ∉ range_vars s"
shows "s(v := t) = s ∘⇩s (Var(v := t))"
unfolding subst_compose_def
proof -
{ fix w
have "(s(v := t)) w = s w ⋅ Var(v := t)"
proof (cases "w = v")
case True
hence "s w = Var w" using ‹v ∉ subst_domain s› by (simp add: subst_domain_def)
thus ?thesis using ‹w = v› by simp
next
case False
hence "(s(v := t)) w = s w" by simp
moreover have "s w ⋅ Var(v := t) = s w" using ‹w ≠ v› ‹v ∉ range_vars s›
by (metis fv_in_subst_img fun_upd_apply insert_absorb insert_subset
repl_invariance subst_apply_term.simps(1) subst_apply_term_empty)
ultimately show ?thesis ..
qed
}
thus "s(v := t) = (λw. s w ⋅ Var(v := t))" by auto
qed
lemma ground_subst_dom_iff_img:
"ground (subst_range σ) ⟹ x ∈ subst_domain σ ⟷ σ x ∈ subst_range σ"
by (auto simp add: subst_domain_def)
lemma finite_dom_subst_exists:
"finite S ⟹ ∃σ::('f,'v) subst. subst_domain σ = S"
proof (induction S rule: finite.induct)
case (insertI A a)
then obtain σ::"('f,'v) subst" where "subst_domain σ = A" by blast
fix f::'f
have "subst_domain (σ(a := Fun f [])) = insert a A"
using ‹subst_domain σ = A›
by (auto simp add: subst_domain_def)
thus ?case by metis
qed (auto simp add: subst_domain_def)
lemma subst_inj_is_bij_betw_dom_img_if_ground_img:
assumes "ground (subst_range σ)"
shows "inj σ ⟷ bij_betw σ (subst_domain σ) (subst_range σ)" (is "?A ⟷ ?B")
proof
show "?A ⟹ ?B" by (metis bij_betw_def injD inj_onI subst_range.simps)
next
assume ?B
hence "inj_on σ (subst_domain σ)" unfolding bij_betw_def by auto
moreover have "⋀x. x ∈ UNIV - subst_domain σ ⟹ σ x = Var x" by auto
hence "inj_on σ (UNIV - subst_domain σ)"
using inj_onI[of "UNIV - subst_domain σ"]
by (metis term.inject(1))
moreover have "⋀x y. x ∈ subst_domain σ ⟹ y ∉ subst_domain σ ⟹ σ x ≠ σ y"
using assms by (auto simp add: subst_domain_def)
ultimately show ?A by (metis injI inj_onD subst_domI term.inject(1))
qed
lemma bij_finite_ground_subst_exists:
assumes "finite (S::'v set)" "infinite (U::('f,'v) term set)" "ground U"
shows "∃σ::('f,'v) subst. subst_domain σ = S
∧ bij_betw σ (subst_domain σ) (subst_range σ)
∧ subst_range σ ⊆ U"
proof -
obtain T' where "T' ⊆ U" "card T' = card S" "finite T'"
by (meson assms(2) finite_Diff2 infinite_arbitrarily_large)
then obtain f::"'v ⇒ ('f,'v) term" where f_bij: "bij_betw f S T'"
using finite_same_card_bij[OF assms(1)] by metis
hence *: "⋀v. v ∈ S ⟹ f v ≠ Var v"
using ‹ground U› ‹T' ⊆ U› bij_betwE
by fastforce
let ?σ = "λv. if v ∈ S then f v else Var v"
have "subst_domain ?σ = S"
proof
show "subst_domain ?σ ⊆ S" by (auto simp add: subst_domain_def)
{ fix v assume "v ∈ S" "v ∉ subst_domain ?σ"
hence "f v = Var v" by (simp add: subst_domain_def)
hence False using *[OF ‹v ∈ S›] by metis
}
thus "S ⊆ subst_domain ?σ" by blast
qed
hence "⋀v w. ⟦v ∈ subst_domain ?σ; w ∉ subst_domain ?σ⟧ ⟹ ?σ w ≠ ?σ v"
using ‹ground U› bij_betwE[OF f_bij] set_rev_mp[OF _ ‹T' ⊆ U›]
by (metis (no_types, lifting) UN_iff empty_iff vars_iff_subterm_or_eq fv⇩s⇩e⇩t.simps)
hence "inj_on ?σ (subst_domain ?σ)"
using f_bij ‹subst_domain ?σ = S›
unfolding bij_betw_def inj_on_def
by metis
hence "bij_betw ?σ (subst_domain ?σ) (subst_range ?σ)"
using inj_on_imp_bij_betw[of ?σ] by simp
moreover have "subst_range ?σ = T'"
using ‹bij_betw f S T'› ‹subst_domain ?σ = S›
unfolding bij_betw_def by auto
hence "subst_range ?σ ⊆ U" using ‹T' ⊆ U› by auto
ultimately show ?thesis using ‹subst_domain ?σ = S› by (metis (lifting))
qed
lemma bij_finite_const_subst_exists:
assumes "finite (S::'v set)" "finite (T::'f set)" "infinite (U::'f set)"
shows "∃σ::('f,'v) subst. subst_domain σ = S
∧ bij_betw σ (subst_domain σ) (subst_range σ)
∧ subst_range σ ⊆ (λc. Fun c []) ` (U - T)"
proof -
obtain T' where "T' ⊆ U - T" "card T' = card S" "finite T'"
by (meson assms(2,3) finite_Diff2 infinite_arbitrarily_large)
then obtain f::"'v ⇒ 'f" where f_bij: "bij_betw f S T'"
using finite_same_card_bij[OF assms(1)] by metis
let ?σ = "λv. if v ∈ S then Fun (f v) [] else Var v"
have "subst_domain ?σ = S" by (simp add: subst_domain_def)
moreover have "⋀v w. ⟦v ∈ subst_domain ?σ; w ∉ subst_domain ?σ⟧ ⟹ ?σ w ≠ ?σ v" by auto
hence "inj_on ?σ (subst_domain ?σ)"
using f_bij unfolding bij_betw_def inj_on_def
by (metis ‹subst_domain ?σ = S› term.inject(2))
hence "bij_betw ?σ (subst_domain ?σ) (subst_range ?σ)"
using inj_on_imp_bij_betw[of ?σ] by simp
moreover have "subst_range ?σ = ((λc. Fun c []) ` T')"
using ‹bij_betw f S T'› unfolding bij_betw_def inj_on_def by (auto simp add: subst_domain_def)
hence "subst_range ?σ ⊆ ((λc. Fun c []) ` (U - T))" using ‹T' ⊆ U - T› by auto
ultimately show ?thesis by (metis (lifting))
qed
lemma bij_finite_const_subst_exists':
assumes "finite (S::'v set)" "finite (T::('f,'v) terms)" "infinite (U::'f set)"
shows "∃σ::('f,'v) subst. subst_domain σ = S
∧ bij_betw σ (subst_domain σ) (subst_range σ)
∧ subst_range σ ⊆ ((λc. Fun c []) ` U) - T"
proof -
have "finite (⋃(funs_term ` T))" using assms(2) by auto
then obtain σ where σ:
"subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
"subst_range σ ⊆ (λc. Fun c []) ` (U - (⋃(funs_term ` T)))"
using bij_finite_const_subst_exists[OF assms(1) _ assms(3)] by blast
moreover have "(λc. Fun c []) ` (U - (⋃(funs_term ` T))) ⊆ ((λc. Fun c []) ` U) - T" by auto
ultimately show ?thesis by blast
qed
lemma bij_betw_iteI:
assumes "bij_betw f A B" "bij_betw g C D" "A ∩ C = {}" "B ∩ D = {}"
shows "bij_betw (λx. if x ∈ A then f x else g x) (A ∪ C) (B ∪ D)"
proof -
have "bij_betw (λx. if x ∈ A then f x else g x) A B"
by (metis bij_betw_cong[of A f "λx. if x ∈ A then f x else g x" B] assms(1))
moreover have "bij_betw (λx. if x ∈ A then f x else g x) C D"
using bij_betw_cong[of C g "λx. if x ∈ A then f x else g x" D] assms(2,3) by force
ultimately show ?thesis using bij_betw_combine[OF _ _ assms(4)] by metis
qed
lemma subst_comp_split:
assumes "subst_domain θ ∩ range_vars θ = {}"
shows "θ = (rm_vars (subst_domain θ - V) θ) ∘⇩s (rm_vars V θ)" (is ?P)
and "θ = (rm_vars V θ) ∘⇩s (rm_vars (subst_domain θ - V) θ)" (is ?Q)
proof -
let ?rm1 = "rm_vars (subst_domain θ - V) θ" and ?rm2 = "rm_vars V θ"
have "subst_domain ?rm2 ∩ range_vars ?rm1 = {}"
"subst_domain ?rm1 ∩ range_vars ?rm2 = {}"
using assms unfolding range_vars_alt_def by (force simp add: subst_domain_def)+
hence *: "⋀v. v ∈ subst_domain ?rm1 ⟹ (?rm1 ∘⇩s ?rm2) v = θ v"
"⋀v. v ∈ subst_domain ?rm2 ⟹ (?rm2 ∘⇩s ?rm1) v = θ v"
using ident_comp_subst_trm_if_disj[of ?rm2 ?rm1]
ident_comp_subst_trm_if_disj[of ?rm1 ?rm2]
by (auto simp add: subst_domain_def)
hence "⋀v. v ∉ subst_domain ?rm1 ⟹ (?rm1 ∘⇩s ?rm2) v = θ v"
"⋀v. v ∉ subst_domain ?rm2 ⟹ (?rm2 ∘⇩s ?rm1) v = θ v"
unfolding subst_compose_def by (auto simp add: subst_domain_def)
hence "⋀v. (?rm1 ∘⇩s ?rm2) v = θ v" "⋀v. (?rm2 ∘⇩s ?rm1) v = θ v" using * by blast+
thus ?P ?Q by auto
qed
lemma subst_comp_eq_if_disjoint_vars:
assumes "(subst_domain δ ∪ range_vars δ) ∩ (subst_domain γ ∪ range_vars γ) = {}"
shows "γ ∘⇩s δ = δ ∘⇩s γ"
proof -
{ fix x assume "x ∈ subst_domain γ"
hence "(γ ∘⇩s δ) x = γ x" "(δ ∘⇩s γ) x = γ x"
using assms unfolding range_vars_alt_def by (force simp add: subst_compose)+
hence "(γ ∘⇩s δ) x = (δ ∘⇩s γ) x" by metis
} moreover
{ fix x assume "x ∈ subst_domain δ"
hence "(γ ∘⇩s δ) x = δ x" "(δ ∘⇩s γ) x = δ x"
using assms
unfolding range_vars_alt_def by (auto simp add: subst_compose subst_domain_def)
hence "(γ ∘⇩s δ) x = (δ ∘⇩s γ) x" by metis
} moreover
{ fix x assume "x ∉ subst_domain γ" "x ∉ subst_domain δ"
hence "(γ ∘⇩s δ) x = (δ ∘⇩s γ) x" by (simp add: subst_compose subst_domain_def)
} ultimately show ?thesis by auto
qed
lemma subst_eq_if_disjoint_vars_ground:
fixes ξ δ::"('f,'v) subst"
assumes "subst_domain δ ∩ subst_domain ξ = {}" "ground (subst_range ξ)" "ground (subst_range δ)"
shows "t ⋅ δ ⋅ ξ = t ⋅ ξ ⋅ δ"
by (metis assms subst_comp_eq_if_disjoint_vars range_vars_alt_def
subst_subst_compose sup_bot.right_neutral)
lemma subst_img_bound: "subst_domain δ ∪ range_vars δ ⊆ fv t ⟹ range_vars δ ⊆ fv (t ⋅ δ)"
proof -
assume "subst_domain δ ∪ range_vars δ ⊆ fv t"
hence "subst_domain δ ⊆ fv t" by blast
thus ?thesis
by (metis (no_types) range_vars_alt_def le_iff_sup subst_apply_fv_unfold
subst_apply_fv_union subst_range.simps)
qed
lemma subst_all_fv_subset: "fv t ⊆ fv⇩s⇩e⇩t M ⟹ fv (t ⋅ θ) ⊆ fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
proof -
assume *: "fv t ⊆ fv⇩s⇩e⇩t M"
{ fix v assume "v ∈ fv t"
hence "v ∈ fv⇩s⇩e⇩t M" using * by auto
then obtain t' where "t' ∈ M" "v ∈ fv t'" by auto
hence "fv (θ v) ⊆ fv (t' ⋅ θ)"
by (metis subst_apply_term.simps(1) subst_apply_fv_subset subst_apply_fv_unfold
subtermeq_vars_subset vars_iff_subtermeq)
hence "fv (θ v) ⊆ fv⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)" using ‹t' ∈ M› by auto
}
thus ?thesis using subst_apply_fv_unfold[of t θ] by auto
qed
lemma subst_support_if_mgt_subst_idem:
assumes "θ ≼⇩∘ δ" "subst_idem θ"
shows "θ supports δ"
proof -
from ‹θ ≼⇩∘ δ› obtain σ where σ: "δ = θ ∘⇩s σ" by blast
hence "⋀v. θ v ⋅ δ = Var v ⋅ (θ ∘⇩s θ ∘⇩s σ)" by simp
hence "⋀v. θ v ⋅ δ = Var v ⋅ (θ ∘⇩s σ)" using ‹subst_idem θ › unfolding subst_idem_def by simp
hence "⋀v. θ v ⋅ δ = Var v ⋅ δ" using σ by simp
thus "θ supports δ" by simp
qed
lemma subst_support_iff_mgt_if_subst_idem:
assumes "subst_idem θ"
shows "θ ≼⇩∘ δ ⟷ θ supports δ"
proof
show "θ ≼⇩∘ δ ⟹ θ supports δ" by (fact subst_support_if_mgt_subst_idem[OF _ ‹subst_idem θ›])
show "θ supports δ ⟹ θ ≼⇩∘ δ" by (fact subst_supportD)
qed
lemma subst_support_comp:
fixes θ δ ℐ::"('a,'b) subst"
assumes "θ supports ℐ" "δ supports ℐ"
shows "(θ ∘⇩s δ) supports ℐ"
by (metis (no_types) assms subst_agreement subst_apply_term.simps(1) subst_subst_compose)
lemma subst_support_comp':
fixes θ δ σ::"('a,'b) subst"
assumes "θ supports δ"
shows "θ supports (δ ∘⇩s σ)" "σ supports δ ⟹ θ supports (σ ∘⇩s δ)"
using assms unfolding subst_support_def by (metis subst_compose_assoc, metis)
lemma subst_support_comp_split:
fixes θ δ ℐ::"('a,'b) subst"
assumes "(θ ∘⇩s δ) supports ℐ"
shows "subst_domain θ ∩ range_vars θ = {} ⟹ θ supports ℐ"
and "subst_domain θ ∩ subst_domain δ = {} ⟹ δ supports ℐ"
proof -
assume "subst_domain θ ∩ range_vars θ = {}"
hence "subst_idem θ" by (metis subst_idemI)
have "θ ≼⇩∘ ℐ" using assms subst_compose_assoc[of θ δ ℐ] unfolding subst_compose_def by metis
show "θ supports ℐ" using subst_support_if_mgt_subst_idem[OF ‹θ ≼⇩∘ ℐ› ‹subst_idem θ›] by auto
next
assume "subst_domain θ ∩ subst_domain δ = {}"
moreover have "∀v ∈ subst_domain (θ ∘⇩s δ). (θ ∘⇩s δ) v ⋅ ℐ = ℐ v" using assms by metis
ultimately have "∀v ∈ subst_domain δ. δ v ⋅ ℐ = ℐ v"
using var_not_in_subst_dom unfolding subst_compose_def
by (metis IntI empty_iff subst_apply_term.simps(1))
thus "δ supports ℐ" by force
qed
lemma subst_idem_support: "subst_idem θ ⟹ θ supports θ ∘⇩s δ"
unfolding subst_idem_def by (metis subst_support_def subst_compose_assoc)
lemma subst_idem_iff_self_support: "subst_idem θ ⟷ θ supports θ"
using subst_support_def[of θ θ] unfolding subst_idem_def by auto
lemma subterm_subst_neq: "t ⊏ t' ⟹ t ⋅ s ≠ t' ⋅ s"
by (metis subst_mono_neq)
lemma fv_Fun_subst_neq: "x ∈ fv (Fun f T) ⟹ σ x ≠ Fun f T ⋅ σ"
using subterm_subst_neq[of "Var x" "Fun f T"] vars_iff_subterm_or_eq[of x "Fun f T"] by auto
lemma subterm_subst_unfold:
assumes "t ⊑ s ⋅ θ"
shows "(∃s'. s' ⊑ s ∧ t = s' ⋅ θ) ∨ (∃x ∈ fv s. t ⊏ θ x)"
using assms
proof (induction s)
case (Fun f T) thus ?case
proof (cases "t = Fun f T ⋅ θ")
case True thus ?thesis using Fun by auto
next
case False
then obtain s' where s': "s' ∈ set T" "t ⊑ s' ⋅ θ" using Fun by auto
hence "(∃s''. s'' ⊑ s' ∧ t = s'' ⋅ θ) ∨ (∃x ∈ fv s'. t ⊏ θ x)" by (metis Fun.IH)
thus ?thesis using s'(1) by auto
qed
qed simp
lemma subterm_subst_img_subterm:
assumes "t ⊑ s ⋅ θ" "⋀s'. s' ⊑ s ⟹ t ≠ s' ⋅ θ"
shows "∃w ∈ fv s. t ⊏ θ w"
using subterm_subst_unfold[OF assms(1)] assms(2) by force
lemma subterm_subst_not_img_subterm:
assumes "t ⊑ s ⋅ ℐ" "¬(∃w ∈ fv s. t ⊑ ℐ w)"
shows "∃f T. Fun f T ⊑ s ∧ t = Fun f T ⋅ ℐ"
proof (rule ccontr)
assume "¬(∃f T. Fun f T ⊑ s ∧ t = Fun f T ⋅ ℐ)"
hence "⋀f T. Fun f T ⊑ s ⟹ t ≠ Fun f T ⋅ ℐ" by simp
moreover have "⋀x. Var x ⊑ s ⟹ t ≠ Var x ⋅ ℐ"
using assms(2) vars_iff_subtermeq by force
ultimately have "⋀s'. s' ⊑ s ⟹ t ≠ s' ⋅ ℐ" by (metis "term.exhaust")
thus False using assms subterm_subst_img_subterm by blast
qed
lemma subst_apply_img_var:
assumes "v ∈ fv (t ⋅ δ)" "v ∉ fv t"
obtains w where "w ∈ fv t" "v ∈ fv (δ w)"
using assms by (induct t) auto
lemma subst_apply_img_var':
assumes "x ∈ fv (t ⋅ δ)" "x ∉ fv t"
shows "∃y ∈ fv t. x ∈ fv (δ y)"
by (metis assms subst_apply_img_var)
lemma nth_map_subst:
fixes θ::"('f,'v) subst" and T::"('f,'v) term list" and i::nat
shows "i < length T ⟹ (map (λt. t ⋅ θ) T) ! i = (T ! i) ⋅ θ"
by (fact nth_map)
lemma subst_subterm:
assumes "Fun f T ⊑ t ⋅ θ"
shows "(∃S. Fun f S ⊑ t ∧ Fun f S ⋅ θ = Fun f T) ∨
(∃s ∈ subst_range θ. Fun f T ⊑ s)"
using assms subterm_subst_not_img_subterm by (cases "∃s ∈ subst_range θ. Fun f T ⊑ s") fastforce+
lemma subst_subterm':
assumes "Fun f T ⊑ t ⋅ θ"
shows "∃S. length S = length T ∧ (Fun f S ⊑ t ∨ (∃s ∈ subst_range θ. Fun f S ⊑ s))"
using subst_subterm[OF assms] by auto
lemma subst_subterm'':
assumes "s ∈ subterms (t ⋅ θ)"
shows "(∃u ∈ subterms t. s = u ⋅ θ) ∨ s ∈ subterms⇩s⇩e⇩t (subst_range θ)"
proof (cases s)
case (Var x)
thus ?thesis
using assms subterm_subst_not_img_subterm vars_iff_subtermeq
by (cases "s = t ⋅ θ") fastforce+
next
case (Fun f T)
thus ?thesis
using subst_subterm[of f T t θ] assms
by fastforce
qed
subsection ‹More Small Lemmata›
lemma funs_term_subst: "funs_term (t ⋅ θ) = funs_term t ∪ (⋃x ∈ fv t. funs_term (θ x))"
by (induct t) auto
lemma fv⇩s⇩e⇩t_subst_img_eq:
assumes "X ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv⇩s⇩e⇩t (δ ` (Y - X)) = fv⇩s⇩e⇩t (δ ` Y) - X"
using assms unfolding range_vars_alt_def by force
lemma subst_Fun_index_eq:
assumes "i < length T" "Fun f T ⋅ δ = Fun g T' ⋅ δ"
shows "T ! i ⋅ δ = T' ! i ⋅ δ"
proof -
have "map (λx. x ⋅ δ) T = map (λx. x ⋅ δ) T'" using assms by simp
thus ?thesis by (metis assms(1) length_map nth_map)
qed
lemma fv_exists_if_unifiable_and_neq:
fixes t t'::"('a,'b) term" and δ θ::"('a,'b) subst"
assumes "t ≠ t'" "t ⋅ θ = t' ⋅ θ"
shows "fv t ∪ fv t' ≠ {}"
proof
assume "fv t ∪ fv t' = {}"
hence "fv t = {}" "fv t' = {}" by auto
hence "t ⋅ θ = t" "t' ⋅ θ = t'" by auto
hence "t = t'" using assms(2) by metis
thus False using assms(1) by auto
qed
lemma const_subterm_subst: "Fun c [] ⊑ t ⟹ Fun c [] ⊑ t ⋅ σ"
by (induct t) auto
lemma const_subterm_subst_var_obtain:
assumes "Fun c [] ⊑ t ⋅ σ" "¬Fun c [] ⊑ t"
obtains x where "x ∈ fv t" "Fun c [] ⊑ σ x"
using assms by (induct t) auto
lemma const_subterm_subst_cases:
assumes "Fun c [] ⊑ t ⋅ σ"
shows "Fun c [] ⊑ t ∨ (∃x ∈ fv t. x ∈ subst_domain σ ∧ Fun c [] ⊑ σ x)"
proof (cases "Fun c [] ⊑ t")
case False
then obtain x where "x ∈ fv t" "Fun c [] ⊑ σ x"
using const_subterm_subst_var_obtain[OF assms] by moura
thus ?thesis by (cases "x ∈ subst_domain σ") auto
qed simp
lemma fv⇩p⇩a⇩i⇩r⇩s_subst_fv_subset:
assumes "x ∈ fv⇩p⇩a⇩i⇩r⇩s F"
shows "fv (θ x) ⊆ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ)"
using assms
proof (induction F)
case (Cons f F)
then obtain t t' where f: "f = (t,t')" by (metis surj_pair)
show ?case
proof (cases "x ∈ fv⇩p⇩a⇩i⇩r⇩s F")
case True thus ?thesis
using Cons.IH
unfolding subst_apply_pairs_def
by auto
next
case False
hence "x ∈ fv t ∪ fv t'" using Cons.prems f by simp
hence "fv (θ x) ⊆ fv (t ⋅ θ) ∪ fv (t' ⋅ θ)" using fv_subst_subset[of x] by force
thus ?thesis using f unfolding subst_apply_pairs_def by auto
qed
qed simp
lemma fv⇩p⇩a⇩i⇩r⇩s_step_subst: "fv⇩s⇩e⇩t (δ ` fv⇩p⇩a⇩i⇩r⇩s F) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
proof (induction F)
case (Cons f F)
obtain t t' where "f = (t,t')" by moura
thus ?case
using Cons
by (simp add: subst_apply_pairs_def subst_apply_fv_unfold)
qed (simp_all add: subst_apply_pairs_def)
lemma fv⇩p⇩a⇩i⇩r⇩s_subst_obtain_var:
fixes δ::"('a,'b) subst"
assumes "x ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
shows "∃y ∈ fv⇩p⇩a⇩i⇩r⇩s F. x ∈ fv (δ y)"
using assms
proof (induction F)
case (Cons f F)
then obtain t s where f: "f = (t,s)" by (metis surj_pair)
from Cons.IH show ?case
proof (cases "x ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ)")
case False
hence "x ∈ fv (t ⋅ δ) ∨ x ∈ fv (s ⋅ δ)"
using f Cons.prems
by (simp add: subst_apply_pairs_def)
hence "(∃y ∈ fv t. x ∈ fv (δ y)) ∨ (∃y ∈ fv s. x ∈ fv (δ y))" by (metis fv_subst_obtain_var)
thus ?thesis using f by (auto simp add: subst_apply_pairs_def)
qed (auto simp add: Cons.IH)
qed (simp add: subst_apply_pairs_def)
lemma pair_subst_ident[intro]: "(fv t ∪ fv t') ∩ subst_domain θ = {} ⟹ (t,t') ⋅⇩p θ = (t,t')"
by auto
lemma pairs_substI[intro]:
assumes "subst_domain θ ∩ (⋃(s,t) ∈ M. fv s ∪ fv t) = {}"
shows "M ⋅⇩p⇩s⇩e⇩t θ = M"
proof -
{ fix m assume M: "m ∈ M"
then obtain s t where m: "m = (s,t)" by (metis surj_pair)
hence "(fv s ∪ fv t) ∩ subst_domain θ = {}" using assms M by auto
hence "m ⋅⇩p θ = m" using m by auto
} thus ?thesis by (simp add: image_cong)
qed
lemma fv⇩p⇩a⇩i⇩r⇩s_subst: "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ) = fv⇩s⇩e⇩t (θ ` (fv⇩p⇩a⇩i⇩r⇩s F))"
proof (induction F)
case (Cons g G)
obtain t t' where "g = (t,t')" by (metis surj_pair)
thus ?case
using Cons.IH
by (simp add: subst_apply_pairs_def subst_apply_fv_unfold)
qed (simp add: subst_apply_pairs_def)
lemma fv⇩p⇩a⇩i⇩r⇩s_subst_subset:
assumes "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆ subst_domain σ"
shows "fv⇩p⇩a⇩i⇩r⇩s F ⊆ subst_domain σ ∪ subst_domain δ"
using assms
proof (induction F)
case (Cons g G)
hence IH: "fv⇩p⇩a⇩i⇩r⇩s G ⊆ subst_domain σ ∪ subst_domain δ"
by (simp add: subst_apply_pairs_def)
obtain t t' where g: "g = (t,t')" by (metis surj_pair)
hence "fv (t ⋅ δ) ⊆ subst_domain σ" "fv (t' ⋅ δ) ⊆ subst_domain σ"
using Cons.prems by (simp_all add: subst_apply_pairs_def)
hence "fv t ⊆ subst_domain σ ∪ subst_domain δ" "fv t' ⊆ subst_domain σ ∪ subst_domain δ"
using subst_apply_fv_unfold[of _ δ] by force+
thus ?case using IH g by (simp add: subst_apply_pairs_def)
qed (simp add: subst_apply_pairs_def)
lemma pairs_subst_comp: "F ⋅⇩p⇩a⇩i⇩r⇩s δ ∘⇩s θ = ((F ⋅⇩p⇩a⇩i⇩r⇩s δ) ⋅⇩p⇩a⇩i⇩r⇩s θ)"
by (induct F) (auto simp add: subst_apply_pairs_def)
lemma pairs_substI'[intro]:
"subst_domain θ ∩ fv⇩p⇩a⇩i⇩r⇩s F = {} ⟹ F ⋅⇩p⇩a⇩i⇩r⇩s θ = F"
by (induct F) (force simp add: subst_apply_pairs_def)+
lemma subst_pair_compose[simp]: "d ⋅⇩p (δ ∘⇩s ℐ) = d ⋅⇩p δ ⋅⇩p ℐ"
proof -
obtain t s where "d = (t,s)" by moura
thus ?thesis by auto
qed
lemma subst_pairs_compose[simp]: "D ⋅⇩p⇩s⇩e⇩t (δ ∘⇩s ℐ) = D ⋅⇩p⇩s⇩e⇩t δ ⋅⇩p⇩s⇩e⇩t ℐ"
by auto
lemma subst_apply_pair_pair: "(t, s) ⋅⇩p ℐ = (t ⋅ ℐ, s ⋅ ℐ)"
by (rule prod.case)
lemma subst_apply_pairs_nil[simp]: "[] ⋅⇩p⇩a⇩i⇩r⇩s δ = []"
unfolding subst_apply_pairs_def by simp
lemma subst_apply_pairs_singleton[simp]: "[(t,s)] ⋅⇩p⇩a⇩i⇩r⇩s δ = [(t ⋅ δ,s ⋅ δ)]"
unfolding subst_apply_pairs_def by simp
lemma subst_apply_pairs_Var[iff]: "F ⋅⇩p⇩a⇩i⇩r⇩s Var = F" by (simp add: subst_apply_pairs_def)
lemma subst_apply_pairs_pset_subst: "set (F ⋅⇩p⇩a⇩i⇩r⇩s θ) = set F ⋅⇩p⇩s⇩e⇩t θ"
unfolding subst_apply_pairs_def by force
subsection ‹Finite Substitutions›
inductive_set fsubst::"('a,'b) subst set" where
fvar: "Var ∈ fsubst"
| FUpdate: "⟦θ ∈ fsubst; v ∉ subst_domain θ; t ≠ Var v⟧ ⟹ θ(v := t) ∈ fsubst"
lemma finite_dom_iff_fsubst:
"finite (subst_domain θ) ⟷ θ ∈ fsubst"
proof
assume "finite (subst_domain θ)" thus "θ ∈ fsubst"
proof (induction "subst_domain θ" arbitrary: θ rule: finite.induct)
case emptyI
hence "θ = Var" using empty_dom_iff_empty_subst by metis
thus ?case using fvar by simp
next
case (insertI θ'⇩d⇩o⇩m v) thus ?case
proof (cases "v ∈ θ'⇩d⇩o⇩m")
case True
hence "θ'⇩d⇩o⇩m = subst_domain θ" using ‹insert v θ'⇩d⇩o⇩m = subst_domain θ› by auto
thus ?thesis using insertI.hyps(2) by metis
next
case False
let ?θ' = "λw. if w ∈ θ'⇩d⇩o⇩m then θ w else Var w"
have "subst_domain ?θ' = θ'⇩d⇩o⇩m"
using ‹v ∉ θ'⇩d⇩o⇩m› ‹insert v θ'⇩d⇩o⇩m = subst_domain θ›
by (auto simp add: subst_domain_def)
hence "?θ' ∈ fsubst" using insertI.hyps(2) by simp
moreover have "?θ'(v := θ v) = (λw. if w ∈ insert v θ'⇩d⇩o⇩m then θ w else Var w)" by auto
hence "?θ'(v := θ v) = θ"
using ‹insert v θ'⇩d⇩o⇩m = subst_domain θ›
by (auto simp add: subst_domain_def)
ultimately show ?thesis
using FUpdate[of ?θ' v "θ v"] False insertI.hyps(3)
by (auto simp add: subst_domain_def)
qed
qed
next
assume "θ ∈ fsubst" thus "finite (subst_domain θ)"
by (induct θ, simp, metis subst_dom_insert_finite)
qed
lemma fsubst_induct[case_names fvar FUpdate, induct set: finite]:
assumes "finite (subst_domain δ)" "P Var"
and "⋀θ v t. ⟦finite (subst_domain θ); v ∉ subst_domain θ; t ≠ Var v; P θ⟧ ⟹ P (θ(v := t))"
shows "P δ"
using assms finite_dom_iff_fsubst fsubst.induct by metis
lemma fun_upd_fsubst: "s(v := t) ∈ fsubst ⟷ s ∈ fsubst"
using subst_dom_insert_finite[of s] finite_dom_iff_fsubst by blast
lemma finite_img_if_fsubst: "s ∈ fsubst ⟹ finite (subst_range s)"
using finite_dom_iff_fsubst finite_subst_img_if_finite_dom' by blast
subsection ‹Unifiers and Most General Unifiers (MGUs)›
abbreviation Unifier::"('f,'v) subst ⇒ ('f,'v) term ⇒ ('f,'v) term ⇒ bool" where
"Unifier σ t u ≡ (t ⋅ σ = u ⋅ σ)"
abbreviation MGU::"('f,'v) subst ⇒ ('f,'v) term ⇒ ('f,'v) term ⇒ bool" where
"MGU σ t u ≡ Unifier σ t u ∧ (∀θ. Unifier θ t u ⟶ σ ≼⇩∘ θ)"
lemma MGUI[intro]:
shows "⟦t ⋅ σ = u ⋅ σ; ⋀θ::('f,'v) subst. t ⋅ θ = u ⋅ θ ⟹ σ ≼⇩∘ θ⟧ ⟹ MGU σ t u"
by auto
lemma UnifierD[dest]:
fixes σ::"('f,'v) subst" and f g::'f and X Y::"('f,'v) term list"
assumes "Unifier σ (Fun f X) (Fun g Y)"
shows "f = g" "length X = length Y"
proof -
from assms show "f = g" by auto
from assms have "Fun f X ⋅ σ = Fun g Y ⋅ σ" by auto
hence "length (map (λx. x ⋅ σ) X) = length (map (λx. x ⋅ σ) Y)" by auto
thus "length X = length Y" by auto
qed
lemma MGUD[dest]:
fixes σ::"('f,'v) subst" and f g::'f and X Y::"('f,'v) term list"
assumes "MGU σ (Fun f X) (Fun g Y)"
shows "f = g" "length X = length Y"
using assms by (auto intro!: UnifierD[of f X σ g Y])
lemma MGU_sym[sym]: "MGU σ s t ⟹ MGU σ t s" by auto
lemma Unifier_sym[sym]: "Unifier σ s t ⟹ Unifier σ t s" by auto
lemma MGU_nil: "MGU Var s t ⟷ s = t" by fastforce
lemma Unifier_comp: "Unifier (θ ∘⇩s δ) t u ⟹ Unifier δ (t ⋅ θ) (u ⋅ θ)"
by simp
lemma Unifier_comp': "Unifier δ (t ⋅ θ) (u ⋅ θ) ⟹ Unifier (θ ∘⇩s δ) t u"
by simp
lemma Unifier_excludes_subterm:
assumes θ: "Unifier θ t u"
shows "¬t ⊏ u"
proof
assume "t ⊏ u"
hence "t ⋅ θ ⊏ u ⋅ θ" using subst_mono_neq by metis
hence "t ⋅ θ ≠ u ⋅ θ" by simp
moreover from θ have "t ⋅ θ = u ⋅ θ" by auto
ultimately show False ..
qed
lemma MGU_is_Unifier: "MGU σ t u ⟹ Unifier σ t u" by (rule conjunct1)
lemma MGU_Var1:
assumes "¬Var v ⊏ t"
shows "MGU (Var(v := t)) (Var v) t"
proof (intro MGUI exI)
show "Var v ⋅ (Var(v := t)) = t ⋅ (Var(v := t))" using assms subst_no_occs by fastforce
next
fix θ::"('a,'b) subst" assume th: "Var v ⋅ θ = t ⋅ θ"
show "θ = (Var(v := t)) ∘⇩s θ"
proof
fix s show "s ⋅ θ = s ⋅ ((Var(v := t)) ∘⇩s θ)" using th by (induct s) auto
qed
qed
lemma MGU_Var2: "v ∉ fv t ⟹ MGU (Var(v := t)) (Var v) t"
by (metis (no_types) MGU_Var1 vars_iff_subterm_or_eq)
lemma MGU_Var3: "MGU Var (Var v) (Var w) ⟷ v = w" by fastforce
lemma MGU_Const1: "MGU Var (Fun c []) (Fun d []) ⟷ c = d" by fastforce
lemma MGU_Const2: "MGU θ (Fun c []) (Fun d []) ⟹ c = d" by auto
lemma MGU_Fun:
assumes "MGU θ (Fun f X) (Fun g Y)"
shows "f = g" "length X = length Y"
proof -
let ?F = "λθ X. map (λx. x ⋅ θ) X"
from assms have
"⟦f = g; ?F θ X = ?F θ Y; ∀θ'. f = g ∧ ?F θ' X = ?F θ' Y ⟶ θ ≼⇩∘ θ'⟧ ⟹ length X = length Y"
using map_eq_imp_length_eq by auto
thus "f = g" "length X = length Y" using assms by auto
qed
lemma Unifier_Fun:
assumes "Unifier θ (Fun f (x#X)) (Fun g (y#Y))"
shows "Unifier θ x y" "Unifier θ (Fun f X) (Fun g Y)"
using assms by simp_all
lemma Unifier_subst_idem_subst:
"subst_idem r ⟹ Unifier s (t ⋅ r) (u ⋅ r) ⟹ Unifier (r ∘⇩s s) (t ⋅ r) (u ⋅ r)"
by (metis (no_types, lifting) subst_idem_def subst_subst_compose)
lemma subst_idem_comp:
"subst_idem r ⟹ Unifier s (t ⋅ r) (u ⋅ r) ⟹
(⋀q. Unifier q (t ⋅ r) (u ⋅ r) ⟹ s ∘⇩s q = q) ⟹
subst_idem (r ∘⇩s s)"
by (frule Unifier_subst_idem_subst, blast, metis subst_idem_def subst_compose_assoc)
lemma Unifier_mgt: "⟦Unifier δ t u; δ ≼⇩∘ θ⟧ ⟹ Unifier θ t u" by auto
lemma Unifier_support: "⟦Unifier δ t u; δ supports θ⟧ ⟹ Unifier θ t u"
using subst_supportD Unifier_mgt by metis
lemma MGU_mgt: "⟦MGU σ t u; MGU δ t u⟧ ⟹ σ ≼⇩∘ δ" by auto
lemma Unifier_trm_fv_bound:
"⟦Unifier s t u; v ∈ fv t⟧ ⟹ v ∈ subst_domain s ∪ range_vars s ∪ fv u"
proof (induction t arbitrary: s u)
case (Fun f X)
hence "v ∈ fv (u ⋅ s) ∨ v ∈ subst_domain s" by (metis subst_not_dom_fixed)
thus ?case by (metis (no_types) Un_iff contra_subsetD subst_sends_fv_to_img)
qed (metis (no_types) UnI1 UnI2 subsetCE no_var_subterm subst_sends_dom_to_img
subst_to_var_is_var trm_subst_ident' vars_iff_subterm_or_eq)
lemma Unifier_rm_var: "⟦Unifier θ s t; v ∉ fv s ∪ fv t⟧ ⟹ Unifier (rm_var v θ) s t"
by (auto simp add: repl_invariance)
lemma Unifier_ground_rm_vars:
assumes "ground (subst_range s)" "Unifier (rm_vars X s) t t'"
shows "Unifier s t t'"
by (rule Unifier_support[OF assms(2) rm_vars_ground_supports[OF assms(1)]])
lemma Unifier_dom_restrict:
assumes "Unifier s t t'" "fv t ∪ fv t' ⊆ S"
shows "Unifier (rm_vars (UNIV - S) s) t t'"
proof -
let ?s = "rm_vars (UNIV - S) s"
show ?thesis using term_subst_eq_conv[of t s ?s] term_subst_eq_conv[of t' s ?s] assms by auto
qed
subsection ‹Well-formedness of Substitutions and Unifiers›
inductive_set wf⇩s⇩u⇩b⇩s⇩t_set::"('a,'b) subst set" where
Empty[simp]: "Var ∈ wf⇩s⇩u⇩b⇩s⇩t_set"
| Insert[simp]:
"⟦θ ∈ wf⇩s⇩u⇩b⇩s⇩t_set; v ∉ subst_domain θ;
v ∉ range_vars θ; fv t ∩ (insert v (subst_domain θ)) = {}⟧
⟹ θ(v := t) ∈ wf⇩s⇩u⇩b⇩s⇩t_set"
definition wf⇩s⇩u⇩b⇩s⇩t::"('a,'b) subst ⇒ bool" where
"wf⇩s⇩u⇩b⇩s⇩t θ ≡ subst_domain θ ∩ range_vars θ = {} ∧ finite (subst_domain θ)"
definition wf⇩M⇩G⇩U::"('a,'b) subst ⇒ ('a,'b) term ⇒ ('a,'b) term ⇒ bool" where
"wf⇩M⇩G⇩U θ s t ≡ wf⇩s⇩u⇩b⇩s⇩t θ ∧ MGU θ s t ∧ subst_domain θ ∪ range_vars θ ⊆ fv s ∪ fv t"
lemma wf_subst_subst_idem: "wf⇩s⇩u⇩b⇩s⇩t θ ⟹ subst_idem θ" using subst_idemI[of θ] unfolding wf⇩s⇩u⇩b⇩s⇩t_def by fast
lemma wf_subst_properties: "θ ∈ wf⇩s⇩u⇩b⇩s⇩t_set = wf⇩s⇩u⇩b⇩s⇩t θ"
proof
show "wf⇩s⇩u⇩b⇩s⇩t θ ⟹ θ ∈ wf⇩s⇩u⇩b⇩s⇩t_set" unfolding wf⇩s⇩u⇩b⇩s⇩t_def
proof -
assume "subst_domain θ ∩ range_vars θ = {} ∧ finite (subst_domain θ)"
hence "finite (subst_domain θ)" "subst_domain θ ∩ range_vars θ = {}"
by auto
thus "θ ∈ wf⇩s⇩u⇩b⇩s⇩t_set"
proof (induction θ rule: fsubst_induct)
case fvar thus ?case by simp
next
case (FUpdate δ v t)
have "subst_domain δ ⊆ subst_domain (δ(v := t))" "range_vars δ ⊆ range_vars (δ(v := t))"
using FUpdate.hyps(2,3) subst_img_update
unfolding range_vars_alt_def by (fastforce simp add: subst_domain_def)+
hence "subst_domain δ ∩ range_vars δ = {}" using FUpdate.prems(1) by blast
hence "δ ∈ wf⇩s⇩u⇩b⇩s⇩t_set" using FUpdate.IH by metis
have *: "range_vars (δ(v := t)) = range_vars δ ∪ fv t"
using FUpdate.hyps(2) subst_img_update[OF _ FUpdate.hyps(3)]
by fastforce
hence "fv t ∩ insert v (subst_domain δ) = {}"
using FUpdate.prems subst_dom_update2[OF FUpdate.hyps(3)] by blast
moreover have "subst_domain (δ(v := t)) = insert v (subst_domain δ)"
by (meson FUpdate.hyps(3) subst_dom_update2)
hence "v ∉ range_vars δ" using FUpdate.prems * by blast
ultimately show ?case using Insert[OF ‹δ ∈ wf⇩s⇩u⇩b⇩s⇩t_set› ‹v ∉ subst_domain δ›] by metis
qed
qed
show "θ ∈ wf⇩s⇩u⇩b⇩s⇩t_set ⟹ wf⇩s⇩u⇩b⇩s⇩t θ" unfolding wf⇩s⇩u⇩b⇩s⇩t_def
proof (induction θ rule: wf⇩s⇩u⇩b⇩s⇩t_set.induct)
case Empty thus ?case by simp
next
case (Insert σ v t)
hence 1: "subst_domain σ ∩ range_vars σ = {}" by simp
hence 2: "subst_domain (σ(v := t)) ∩ range_vars σ = {}"
using Insert.hyps(3) by (auto simp add: subst_domain_def)
have 3: "fv t ∩ subst_domain (σ(v := t)) = {}"
using Insert.hyps(4) by (auto simp add: subst_domain_def)
have 4: "σ v = Var v" using ‹v ∉ subst_domain σ› by (simp add: subst_domain_def)
from Insert.IH have "finite (subst_domain σ)" by simp
hence 5: "finite (subst_domain (σ(v := t)))" using subst_dom_insert_finite[of σ] by simp
have "subst_domain (σ(v := t)) ∩ range_vars (σ(v := t)) = {}"
proof (cases "t = Var v")
case True
hence "range_vars (σ(v := t)) = range_vars σ"
using 4 fun_upd_triv term.inject(1)
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
thus "subst_domain (σ(v := t)) ∩ range_vars (σ(v := t)) = {}"
using 1 2 3 by auto
next
case False
hence "range_vars (σ(v := t)) = fv t ∪ (range_vars σ)"
using 4 subst_img_update[of σ v] by auto
thus "subst_domain (σ(v := t)) ∩ range_vars (σ(v := t)) = {}" using 1 2 3 by blast
qed
thus ?case using 5 by blast
qed
qed
lemma wf⇩s⇩u⇩b⇩s⇩t_induct[consumes 1, case_names Empty Insert]:
assumes "wf⇩s⇩u⇩b⇩s⇩t δ" "P Var"
and "⋀θ v t. ⟦wf⇩s⇩u⇩b⇩s⇩t θ; P θ; v ∉ subst_domain θ; v ∉ range_vars θ;
fv t ∩ insert v (subst_domain θ) = {}⟧
⟹ P (θ(v := t))"
shows "P δ"
proof -
from assms(1,3) wf_subst_properties have
"δ ∈ wf⇩s⇩u⇩b⇩s⇩t_set"
"⋀θ v t. ⟦θ ∈ wf⇩s⇩u⇩b⇩s⇩t_set; P θ; v ∉ subst_domain θ; v ∉ range_vars θ;
fv t ∩ insert v (subst_domain θ) = {}⟧
⟹ P (θ(v := t))"
by blast+
thus "P δ" using wf⇩s⇩u⇩b⇩s⇩t_set.induct assms(2) by blast
qed
lemma wf_subst_fsubst: "wf⇩s⇩u⇩b⇩s⇩t δ ⟹ δ ∈ fsubst"
unfolding wf⇩s⇩u⇩b⇩s⇩t_def using finite_dom_iff_fsubst by blast
lemma wf_subst_nil: "wf⇩s⇩u⇩b⇩s⇩t Var" unfolding wf⇩s⇩u⇩b⇩s⇩t_def by simp
lemma wf_MGU_nil: "MGU Var s t ⟹ wf⇩M⇩G⇩U Var s t"
using wf_subst_nil subst_domain_Var range_vars_Var
unfolding wf⇩M⇩G⇩U_def by fast
lemma wf_MGU_dom_bound: "wf⇩M⇩G⇩U θ s t ⟹ subst_domain θ ⊆ fv s ∪ fv t" unfolding wf⇩M⇩G⇩U_def by blast
lemma wf_subst_single:
assumes "v ∉ fv t" "σ v = t" "⋀w. v ≠ w ⟹ σ w = Var w"
shows "wf⇩s⇩u⇩b⇩s⇩t σ"
proof -
have *: "subst_domain σ = {v}" by (metis subst_fv_dom_img_single(1)[OF assms])
have "subst_domain σ ∩ range_vars σ = {}"
using * assms subst_fv_dom_img_single(2)
by (metis inf_bot_left insert_disjoint(1))
moreover have "finite (subst_domain σ)" using * by simp
ultimately show ?thesis by (metis wf⇩s⇩u⇩b⇩s⇩t_def)
qed
lemma wf_subst_reduction:
"wf⇩s⇩u⇩b⇩s⇩t s ⟹ wf⇩s⇩u⇩b⇩s⇩t (rm_var v s)"
proof -
assume "wf⇩s⇩u⇩b⇩s⇩t s"
moreover have "subst_domain (rm_var v s) ⊆ subst_domain s" by (auto simp add: subst_domain_def)
moreover have "range_vars (rm_var v s) ⊆ range_vars s"
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
ultimately have "subst_domain (rm_var v s) ∩ range_vars (rm_var v s) = {}"
by (meson compl_le_compl_iff disjoint_eq_subset_Compl subset_trans wf⇩s⇩u⇩b⇩s⇩t_def)
moreover have "finite (subst_domain (rm_var v s))"
using ‹subst_domain (rm_var v s) ⊆ subst_domain s› ‹wf⇩s⇩u⇩b⇩s⇩t s› rev_finite_subset
unfolding wf⇩s⇩u⇩b⇩s⇩t_def by blast
ultimately show "wf⇩s⇩u⇩b⇩s⇩t (rm_var v s)" by (metis wf⇩s⇩u⇩b⇩s⇩t_def)
qed
lemma wf_subst_compose:
assumes "wf⇩s⇩u⇩b⇩s⇩t θ1" "wf⇩s⇩u⇩b⇩s⇩t θ2"
and "subst_domain θ1 ∩ subst_domain θ2 = {}"
and "subst_domain θ1 ∩ range_vars θ2 = {}"
shows "wf⇩s⇩u⇩b⇩s⇩t (θ1 ∘⇩s θ2)"
using assms
proof (induction θ1 rule: wf⇩s⇩u⇩b⇩s⇩t_induct)
case Empty thus ?case unfolding wf⇩s⇩u⇩b⇩s⇩t_def by simp
next
case (Insert σ1 v t)
have "t ≠ Var v" using Insert.hyps(4) by auto
hence dom1v_unfold: "subst_domain (σ1(v := t)) = insert v (subst_domain σ1)"
using subst_dom_update2 by metis
hence doms_disj: "subst_domain σ1 ∩ subst_domain θ2 = {}"
using Insert.prems(2) disjoint_insert(1) by blast
moreover have dom_img_disj: "subst_domain σ1 ∩ range_vars θ2 = {}"
using Insert.hyps(2) Insert.prems(3)
by (fastforce simp add: subst_domain_def)
ultimately have "wf⇩s⇩u⇩b⇩s⇩t (σ1 ∘⇩s θ2)" using Insert.IH[OF ‹wf⇩s⇩u⇩b⇩s⇩t θ2›] by metis
have dom_comp_is_union: "subst_domain (σ1 ∘⇩s θ2) = subst_domain σ1 ∪ subst_domain θ2"
using subst_dom_comp_eq[OF dom_img_disj] .
have "v ∉ subst_domain θ2"
using Insert.prems(2) ‹t ≠ Var v›
by (fastforce simp add: subst_domain_def)
hence "θ2 v = Var v" "σ1 v = Var v" using Insert.hyps(2) by (simp_all add: subst_domain_def)
hence "(σ1 ∘⇩s θ2) v = Var v" "(σ1(v := t) ∘⇩s θ2) v = t ⋅ θ2" "((σ1 ∘⇩s θ2)(v := t)) v = t"
unfolding subst_compose_def by simp_all
have fv_t2_bound: "fv (t ⋅ θ2) ⊆ fv t ∪ range_vars θ2" by (meson subst_sends_fv_to_img)
have 1: "v ∉ subst_domain (σ1 ∘⇩s θ2)"
using ‹(σ1 ∘⇩s θ2) v = Var v›
by (auto simp add: subst_domain_def)
have "insert v (subst_domain σ1) ∩ range_vars θ2 = {}"
using Insert.prems(3) dom1v_unfold by blast
hence "v ∉ range_vars σ1 ∪ range_vars θ2" using Insert.hyps(3) by blast
hence 2: "v ∉ range_vars (σ1 ∘⇩s θ2)" by (meson set_rev_mp subst_img_comp_subset)
have "subst_domain θ2 ∩ range_vars θ2 = {}"
using ‹wf⇩s⇩u⇩b⇩s⇩t θ2› unfolding wf⇩s⇩u⇩b⇩s⇩t_def by simp
hence "fv (t ⋅ θ2) ∩ subst_domain θ2 = {}"
using subst_dom_elim unfolding range_vars_alt_def by simp
moreover have "v ∉ range_vars θ2" using Insert.prems(3) dom1v_unfold by blast
hence "v ∉ fv t ∪ range_vars θ2" using Insert.hyps(4) by blast
hence "v ∉ fv (t ⋅ θ2)" using ‹fv (t ⋅ θ2) ⊆ fv t ∪ range_vars θ2› by blast
moreover have "fv (t ⋅ θ2) ∩ subst_domain σ1 = {}"
using dom_img_disj fv_t2_bound ‹fv t ∩ insert v (subst_domain σ1) = {}› by blast
ultimately have 3: "fv (t ⋅ θ2) ∩ insert v (subst_domain (σ1 ∘⇩s θ2)) = {}"
using dom_comp_is_union by blast
have "σ1(v := t) ∘⇩s θ2 = (σ1 ∘⇩s θ2)(v := t ⋅ θ2)" using subst_comp_upd1[of σ1 v t θ2] .
moreover have "wf⇩s⇩u⇩b⇩s⇩t ((σ1 ∘⇩s θ2)(v := t ⋅ θ2))"
using "wf⇩s⇩u⇩b⇩s⇩t_set.Insert"[OF _ 1 2 3] ‹wf⇩s⇩u⇩b⇩s⇩t (σ1 ∘⇩s θ2)› wf_subst_properties by metis
ultimately show ?case by presburger
qed
lemma wf_subst_append:
fixes θ1 θ2::"('f,'v) subst"
assumes "wf⇩s⇩u⇩b⇩s⇩t θ1" "wf⇩s⇩u⇩b⇩s⇩t θ2"
and "subst_domain θ1 ∩ subst_domain θ2 = {}"
and "subst_domain θ1 ∩ range_vars θ2 = {}"
and "range_vars θ1 ∩ subst_domain θ2 = {}"
shows "wf⇩s⇩u⇩b⇩s⇩t (λv. if θ1 v = Var v then θ2 v else θ1 v)"
using assms
proof (induction θ1 rule: wf⇩s⇩u⇩b⇩s⇩t_induct)
case Empty thus ?case unfolding wf⇩s⇩u⇩b⇩s⇩t_def by simp
next
case (Insert σ1 v t)
let ?if = "λw. if σ1 w = Var w then θ2 w else σ1 w"
let ?if_upd = "λw. if (σ1(v := t)) w = Var w then θ2 w else (σ1(v := t)) w"
from Insert.hyps(4) have "?if_upd = ?if(v := t)" by fastforce
have dom_insert: "subst_domain (σ1(v := t)) = insert v (subst_domain σ1)"
using Insert.hyps(4) by (auto simp add: subst_domain_def)
have "σ1 v = Var v" "t ≠ Var v" using Insert.hyps(2,4) by auto
hence img_insert: "range_vars (σ1(v := t)) = range_vars σ1 ∪ fv t"
using subst_img_update by metis
from Insert.prems(2) dom_insert have "subst_domain σ1 ∩ subst_domain θ2 = {}"
by (auto simp add: subst_domain_def)
moreover have "subst_domain σ1 ∩ range_vars θ2 = {}"
using Insert.prems(3) dom_insert
by (simp add: subst_domain_def)
moreover have "range_vars σ1 ∩ subst_domain θ2 = {}"
using Insert.prems(4) img_insert
by blast
ultimately have "wf⇩s⇩u⇩b⇩s⇩t ?if" using Insert.IH[OF Insert.prems(1)] by metis
have dom_union: "subst_domain ?if = subst_domain σ1 ∪ subst_domain θ2"
by (auto simp add: subst_domain_def)
hence "v ∉ subst_domain ?if"
using Insert.hyps(2) Insert.prems(2) dom_insert
by (auto simp add: subst_domain_def)
moreover have "v ∉ range_vars ?if"
using Insert.prems(3) Insert.hyps(3) dom_insert
unfolding range_vars_alt_def by (auto simp add: subst_domain_def)
moreover have "fv t ∩ insert v (subst_domain ?if) = {}"
using Insert.hyps(4) Insert.prems(4) img_insert
unfolding range_vars_alt_def by (fastforce simp add: subst_domain_def)
ultimately show ?case
using wf⇩s⇩u⇩b⇩s⇩t_set.Insert ‹wf⇩s⇩u⇩b⇩s⇩t ?if› ‹?if_upd = ?if(v := t)› wf_subst_properties
by (metis (no_types, lifting))
qed
lemma wf_subst_elim_append:
assumes "wf⇩s⇩u⇩b⇩s⇩t θ" "subst_elim θ v" "v ∉ fv t"
shows "subst_elim (θ(w := t)) v"
using assms
proof (induction θ rule: wf⇩s⇩u⇩b⇩s⇩t_induct)
case (Insert θ v' t')
hence "⋀q. v ∉ fv (Var q ⋅ θ(v' := t'))" using subst_elimD by blast
hence "⋀q. v ∉ fv (Var q ⋅ θ(v' := t', w := t))" using ‹v ∉ fv t› by simp
thus ?case by (metis subst_elimI' subst_apply_term.simps(1))
qed (simp add: subst_elim_def)
lemma wf_subst_elim_dom:
assumes "wf⇩s⇩u⇩b⇩s⇩t θ"
shows "∀v ∈ subst_domain θ. subst_elim θ v"
using assms
proof (induction θ rule: wf⇩s⇩u⇩b⇩s⇩t_induct)
case (Insert θ w t)
have dom_insert: "subst_domain (θ(w := t)) ⊆ insert w (subst_domain θ)"
by (auto simp add: subst_domain_def)
hence "∀v ∈ subst_domain θ. subst_elim (θ(w := t)) v" using Insert.IH Insert.hyps(2,4)
by (metis Insert.hyps(1) IntI disjoint_insert(2) empty_iff wf_subst_elim_append)
moreover have "w ∉ fv t" using Insert.hyps(4) by simp
hence "⋀q. w ∉ fv (Var q ⋅ θ(w := t))"
by (metis fv_simps(1) fv_in_subst_img Insert.hyps(3) contra_subsetD
fun_upd_def singletonD subst_apply_term.simps(1))
hence "subst_elim (θ(w := t)) w" by (metis subst_elimI')
ultimately show ?case using dom_insert by blast
qed simp
lemma wf_subst_support_iff_mgt: "wf⇩s⇩u⇩b⇩s⇩t θ ⟹ θ supports δ ⟷ θ ≼⇩∘ δ"
using subst_support_def subst_support_if_mgt_subst_idem wf_subst_subst_idem by blast
subsection ‹Interpretations›
abbreviation interpretation⇩s⇩u⇩b⇩s⇩t::"('a,'b) subst ⇒ bool" where
"interpretation⇩s⇩u⇩b⇩s⇩t θ ≡ subst_domain θ = UNIV ∧ ground (subst_range θ)"
lemma interpretation_substI:
"(⋀v. fv (θ v) = {}) ⟹ interpretation⇩s⇩u⇩b⇩s⇩t θ"
proof -
assume "⋀v. fv (θ v) = {}"
moreover { fix v assume "fv (θ v) = {}" hence "v ∈ subst_domain θ" by auto }
ultimately show ?thesis by auto
qed
lemma interpretation_grounds[simp]:
"interpretation⇩s⇩u⇩b⇩s⇩t θ ⟹ fv (t ⋅ θ) = {}"
using subst_fv_dom_ground_if_ground_img[of t θ] by blast
lemma interpretation_grounds_all:
"interpretation⇩s⇩u⇩b⇩s⇩t θ ⟹ (⋀v. fv (θ v) = {})"
by (metis range_vars_alt_def UNIV_I fv_in_subst_img subset_empty subst_dom_vars_in_subst)
lemma interpretation_grounds_all':
"interpretation⇩s⇩u⇩b⇩s⇩t θ ⟹ ground (M ⋅⇩s⇩e⇩t θ)"
using subst_fv_dom_ground_if_ground_img[of _ θ]
by simp
lemma interpretation_comp:
assumes "interpretation⇩s⇩u⇩b⇩s⇩t θ"
shows "interpretation⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s θ)" "interpretation⇩s⇩u⇩b⇩s⇩t (θ ∘⇩s σ)"
proof -
have θ_fv: "fv (θ v) = {}" for v using interpretation_grounds_all[OF assms] by simp
hence θ_fv': "fv (t ⋅ θ) = {}" for t
by (metis all_not_in_conv subst_elimD subst_elimI' subst_apply_term.simps(1))
from assms have "(σ ∘⇩s θ) v ≠ Var v" for v
unfolding subst_compose_def by (metis fv_simps(1) θ_fv' insert_not_empty)
hence "subst_domain (σ ∘⇩s θ) = UNIV" by (simp add: subst_domain_def)
moreover have "fv ((σ ∘⇩s θ) v) = {}" for v unfolding subst_compose_def using θ_fv' by simp
hence "ground (subst_range (σ ∘⇩s θ))" by simp
ultimately show "interpretation⇩s⇩u⇩b⇩s⇩t (σ ∘⇩s θ)" ..
from assms have "(θ ∘⇩s σ) v ≠ Var v" for v
unfolding subst_compose_def by (metis fv_simps(1) θ_fv insert_not_empty subst_to_var_is_var)
hence "subst_domain (θ ∘⇩s σ) = UNIV" by (simp add: subst_domain_def)
moreover have "fv ((θ ∘⇩s σ) v) = {}" for v
unfolding subst_compose_def by (simp add: θ_fv trm_subst_ident)
hence "ground (subst_range (θ ∘⇩s σ))" by simp
ultimately show "interpretation⇩s⇩u⇩b⇩s⇩t (θ ∘⇩s σ)" ..
qed
lemma interpretation_subst_exists:
"∃ℐ::('f,'v) subst. interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
proof -
obtain c::"'f" where "c ∈ UNIV" by simp
then obtain ℐ::"('f,'v) subst" where "⋀v. ℐ v = Fun c []" by simp
hence "subst_domain ℐ = UNIV" "ground (subst_range ℐ)"
by (simp_all add: subst_domain_def)
thus ?thesis by auto
qed
lemma interpretation_subst_exists':
"∃θ::('f,'v) subst. subst_domain θ = X ∧ ground (subst_range θ)"
proof -
obtain ℐ::"('f,'v) subst" where ℐ: "subst_domain ℐ = UNIV" "ground (subst_range ℐ)"
using interpretation_subst_exists by moura
let ?θ = "rm_vars (UNIV - X) ℐ"
have 1: "subst_domain ?θ = X" using ℐ by (auto simp add: subst_domain_def)
hence 2: "ground (subst_range ?θ)" using ℐ by force
show ?thesis using 1 2 by blast
qed
lemma interpretation_subst_idem:
"interpretation⇩s⇩u⇩b⇩s⇩t θ ⟹ subst_idem θ"
unfolding subst_idem_def
using interpretation_grounds_all[of θ] trm_subst_ident subst_eq_if_eq_vars
by fastforce
lemma subst_idem_comp_upd_eq:
assumes "v ∉ subst_domain ℐ" "subst_idem θ"
shows "ℐ ∘⇩s θ = ℐ(v := θ v) ∘⇩s θ"
proof -
from assms(1) have "(ℐ ∘⇩s θ) v = θ v" unfolding subst_compose_def by auto
moreover have "⋀w. w ≠ v ⟹ (ℐ ∘⇩s θ) w = (ℐ(v := θ v) ∘⇩s θ) w" unfolding subst_compose_def by auto
moreover have "(ℐ(v := θ v) ∘⇩s θ) v = θ v" using assms(2) unfolding subst_idem_def subst_compose_def
by (metis fun_upd_same)
ultimately show ?thesis by (metis fun_upd_same fun_upd_triv subst_comp_upd1)
qed
lemma interpretation_dom_img_disjoint:
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ ⟹ subst_domain ℐ ∩ range_vars ℐ = {}"
unfolding range_vars_alt_def by auto
subsection ‹Basic Properties of MGUs›
lemma MGU_is_mgu_singleton: "MGU θ t u = is_mgu θ {(t,u)}"
unfolding is_mgu_def unifiers_def by auto
lemma Unifier_in_unifiers_singleton: "Unifier θ s t ⟷ θ ∈ unifiers {(s,t)}"
unfolding unifiers_def by auto
lemma subst_list_singleton_fv_subset:
"(⋃x ∈ set (subst_list (subst v t) E). fv (fst x) ∪ fv (snd x))
⊆ fv t ∪ (⋃x ∈ set E. fv (fst x) ∪ fv (snd x))"
proof (induction E)
case (Cons x E)
let ?fvs = "λL. ⋃x ∈ set L. fv (fst x) ∪ fv (snd x)"
let ?fvx = "fv (fst x) ∪ fv (snd x)"
let ?fvxsubst = "fv (fst x ⋅ Var(v := t)) ∪ fv (snd x ⋅ Var(v := t))"
have "?fvs (subst_list (subst v t) (x#E)) = ?fvxsubst ∪ ?fvs (subst_list (subst v t) E)"
unfolding subst_list_def subst_def by auto
hence "?fvs (subst_list (subst v t) (x#E)) ⊆ ?fvxsubst ∪ fv t ∪ ?fvs E"
using Cons.IH by blast
moreover have "?fvs (x#E) = ?fvx ∪ ?fvs E" by auto
moreover have "?fvxsubst ⊆ ?fvx ∪ fv t" using subst_fv_bound_singleton[of _ v t] by blast
ultimately show ?case unfolding range_vars_alt_def by auto
qed (simp add: subst_list_def)
lemma subst_of_dom_subset: "subst_domain (subst_of L) ⊆ set (map fst L)"
proof (induction L rule: List.rev_induct)
case (snoc x L)
then obtain v t where x: "x = (v,t)" by (metis surj_pair)
hence "subst_of (L@[x]) = Var(v := t) ∘⇩s subst_of L"
unfolding subst_of_def subst_def by (induct L) auto
hence "subst_domain (subst_of (L@[x])) ⊆ insert v (subst_domain (subst_of L))"
using x subst_domain_compose[of "Var(v := t)" "subst_of L"]
by (auto simp add: subst_domain_def)
thus ?case using snoc.IH x by auto
qed simp
lemma wf_MGU_is_imgu_singleton: "wf⇩M⇩G⇩U θ s t ⟹ is_imgu θ {(s,t)}"
proof -
assume 1: "wf⇩M⇩G⇩U θ s t"
have 2: "subst_idem θ" by (metis wf_subst_subst_idem 1 wf⇩M⇩G⇩U_def)
have 3: "∀θ' ∈ unifiers {(s,t)}. θ ≼⇩∘ θ'" "θ ∈ unifiers {(s,t)}"
by (metis 1 Unifier_in_unifiers_singleton wf⇩M⇩G⇩U_def)+
have "∀τ ∈ unifiers {(s,t)}. τ = θ ∘⇩s τ" by (metis 2 3 subst_idem_def subst_compose_assoc)
thus "is_imgu θ {(s,t)}" by (metis is_imgu_def ‹θ ∈ unifiers {(s,t)}›)
qed
lemma mgu_subst_range_vars:
assumes "mgu s t = Some σ" shows "range_vars σ ⊆ vars_term s ∪ vars_term t"
proof -
obtain xs where *: "Unification.unify [(s, t)] [] = Some xs" and [simp]: "subst_of xs = σ"
using assms by (simp split: option.splits)
from unify_Some_UNIF [OF *] obtain ss
where "compose ss = σ" and "UNIF ss {#(s, t)#} {#}" by auto
with UNIF_range_vars_subset [of ss "{#(s, t)#}" "{#}"]
show ?thesis by (metis vars_mset_singleton fst_conv snd_conv)
qed
lemma mgu_subst_domain_range_vars_disjoint:
assumes "mgu s t = Some σ" shows "subst_domain σ ∩ range_vars σ = {}"
proof -
have "is_imgu σ {(s, t)}" using assms mgu_sound by simp
hence "σ = σ ∘⇩s σ" unfolding is_imgu_def by blast
thus ?thesis by (metis subst_idemp_iff)
qed
lemma mgu_same_empty: "mgu (t::('a,'b) term) t = Some Var"
proof -
{ fix E::"('a,'b) equation list" and U::"('b × ('a,'b) term) list"
assume "∀(s,t) ∈ set E. s = t"
hence "Unification.unify E U = Some U"
proof (induction E U rule: Unification.unify.induct)
case (2 f S g T E U)
hence *: "f = g" "S = T" by auto
moreover have "∀(s,t) ∈ set (zip T T). s = t" by (induct T) auto
hence "∀(s,t) ∈ set (zip T T@E). s = t" using "2.prems"(1) by auto
moreover have "zip_option S T = Some (zip S T)" using ‹S = T› by auto
hence **: "decompose (Fun f S) (Fun g T) = Some (zip S T)"
using ‹f = g› unfolding decompose_def by auto
ultimately have "Unification.unify (zip S T@E) U = Some U" using "2.IH" * by auto
thus ?case using ** by auto
qed auto
}
hence "Unification.unify [(t,t)] [] = Some []" by auto
thus ?thesis by auto
qed
lemma mgu_var: assumes "x ∉ fv t" shows "mgu (Var x) t = Some (Var(x := t))"
proof -
have "unify [(Var x,t)] [] = Some [(x,t)]" using assms by (auto simp add: subst_list_def)
moreover have "subst_of [(x,t)] = Var(x := t)" unfolding subst_of_def subst_def by simp
ultimately show ?thesis by simp
qed
lemma mgu_gives_wellformed_subst:
assumes "mgu s t = Some θ" shows "wf⇩s⇩u⇩b⇩s⇩t θ"
using mgu_finite_subst_domain[OF assms] mgu_subst_domain_range_vars_disjoint[OF assms]
unfolding wf⇩s⇩u⇩b⇩s⇩t_def
by auto
lemma mgu_gives_wellformed_MGU:
assumes "mgu s t = Some θ" shows "wf⇩M⇩G⇩U θ s t"
using mgu_subst_domain[OF assms] mgu_sound[OF assms] mgu_subst_range_vars [OF assms]
MGU_is_mgu_singleton[of s θ t] is_imgu_imp_is_mgu[of θ "{(s,t)}"]
mgu_gives_wellformed_subst[OF assms]
unfolding wf⇩M⇩G⇩U_def by blast
lemma mgu_vars_bounded[dest?]:
"mgu M N = Some σ ⟹ subst_domain σ ∪ range_vars σ ⊆ fv M ∪ fv N"
using mgu_gives_wellformed_MGU unfolding wf⇩M⇩G⇩U_def by blast
lemma mgu_gives_subst_idem: "mgu s t = Some θ ⟹ subst_idem θ"
using mgu_sound[of s t θ] unfolding is_imgu_def subst_idem_def by auto
lemma mgu_always_unifies: "Unifier θ M N ⟹ ∃δ. mgu M N = Some δ"
using mgu_complete Unifier_in_unifiers_singleton by blast
lemma mgu_gives_MGU: "mgu s t = Some θ ⟹ MGU θ s t"
using mgu_sound[of s t θ, THEN is_imgu_imp_is_mgu] MGU_is_mgu_singleton by metis
lemma mgu_eliminates[dest?]:
assumes "mgu M N = Some σ"
shows "(∃v ∈ fv M ∪ fv N. subst_elim σ v) ∨ σ = Var"
(is "?P M N σ")
proof (cases "σ = Var")
case False
then obtain v where v: "v ∈ subst_domain σ" by auto
hence "v ∈ fv M ∪ fv N" using mgu_vars_bounded[OF assms] by blast
thus ?thesis using wf_subst_elim_dom[OF mgu_gives_wellformed_subst[OF assms]] v by blast
qed simp
lemma mgu_eliminates_dom:
assumes "mgu x y = Some θ" "v ∈ subst_domain θ"
shows "subst_elim θ v"
using mgu_gives_wellformed_subst[OF assms(1)]
unfolding wf⇩M⇩G⇩U_def wf⇩s⇩u⇩b⇩s⇩t_def subst_elim_def
by (metis disjoint_iff_not_equal subst_dom_elim assms(2))
lemma unify_list_distinct:
assumes "Unification.unify E B = Some U" "distinct (map fst B)"
and "(⋃x ∈ set E. fv (fst x) ∪ fv (snd x)) ∩ set (map fst B) = {}"
shows "distinct (map fst U)"
using assms
proof (induction E B arbitrary: U rule: Unification.unify.induct)
case 1 thus ?case by simp
next
case (2 f X g Y E B U)
let ?fvs = "λL. ⋃x ∈ set L. fv (fst x) ∪ fv (snd x)"
from "2.prems"(1) obtain E' where *: "decompose (Fun f X) (Fun g Y) = Some E'"
and [simp]: "f = g" "length X = length Y" "E' = zip X Y"
and **: "Unification.unify (E'@E) B = Some U"
by (auto split: option.splits)
hence "⋀t t'. (t,t') ∈ set E' ⟹ fv t ⊆ fv (Fun f X) ∧ fv t' ⊆ fv (Fun g Y)"
by (metis zip_arg_subterm subtermeq_vars_subset)
hence "?fvs E' ⊆ fv (Fun f X) ∪ fv (Fun g Y)" by fastforce
moreover have "fv (Fun f X) ∩ set (map fst B) = {}" "fv (Fun g Y) ∩ set (map fst B) = {}"
using "2.prems"(3) by auto
ultimately have "?fvs E' ∩ set (map fst B) = {}" by blast
moreover have "?fvs E ∩ set (map fst B) = {}" using "2.prems"(3) by auto
ultimately have "?fvs (E'@E) ∩ set (map fst B) = {}" by auto
thus ?case using "2.IH"[OF * ** "2.prems"(2)] by metis
next
case (3 v t E B)
let ?fvs = "λL. ⋃x ∈ set L. fv (fst x) ∪ fv (snd x)"
let ?E' = "subst_list (subst v t) E"
from "3.prems"(3) have "v ∉ set (map fst B)" "fv t ∩ set (map fst B) = {}" by force+
hence *: "distinct (map fst ((v, t)#B))" using "3.prems"(2) by auto
show ?case
proof (cases "t = Var v")
case True thus ?thesis using "3.prems" "3.IH"(1) by auto
next
case False
hence "v ∉ fv t" using "3.prems"(1) by auto
hence "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U"
using ‹t ≠ Var v› "3.prems"(1) by auto
moreover have "?fvs ?E' ∩ set (map fst ((v, t)#B)) = {}"
proof -
have "v ∉ ?fvs ?E'"
unfolding subst_list_def subst_def
by (simp add: ‹v ∉ fv t› subst_remove_var)
moreover have "?fvs ?E' ⊆ fv t ∪ ?fvs E" by (metis subst_list_singleton_fv_subset)
hence "?fvs ?E' ∩ set (map fst B) = {}" using "3.prems"(3) by auto
ultimately show ?thesis by auto
qed
ultimately show ?thesis using "3.IH"(2)[OF ‹t ≠ Var v› ‹v ∉ fv t› _ *] by metis
qed
next
case (4 f X v E B U)
let ?fvs = "λL. ⋃x ∈ set L. fv (fst x) ∪ fv (snd x)"
let ?E' = "subst_list (subst v (Fun f X)) E"
have *: "?fvs E ∩ set (map fst B) = {}" using "4.prems"(3) by auto
from "4.prems"(1) have "v ∉ fv (Fun f X)" by force
from "4.prems"(3) have **: "v ∉ set (map fst B)" "fv (Fun f X) ∩ set (map fst B) = {}" by force+
hence ***: "distinct (map fst ((v, Fun f X)#B))" using "4.prems"(2) by auto
from "4.prems"(3) have ****: "?fvs ?E' ∩ set (map fst ((v, Fun f X)#B)) = {}"
proof -
have "v ∉ ?fvs ?E'"
unfolding subst_list_def subst_def
using ‹v ∉ fv (Fun f X)› subst_remove_var[of v "Fun f X"] by simp
moreover have "?fvs ?E' ⊆ fv (Fun f X) ∪ ?fvs E" by (metis subst_list_singleton_fv_subset)
hence "?fvs ?E' ∩ set (map fst B) = {}" using * ** by blast
ultimately show ?thesis by auto
qed
have "Unification.unify (subst_list (subst v (Fun f X)) E) ((v, Fun f X) # B) = Some U"
using ‹v ∉ fv (Fun f X)› "4.prems"(1) by auto
thus ?case using "4.IH"[OF ‹v ∉ fv (Fun f X)› _ *** ****] by metis
qed
lemma mgu_None_is_subst_neq:
fixes s t::"('a,'b) term" and δ::"('a,'b) subst"
assumes "mgu s t = None"
shows "s ⋅ δ ≠ t ⋅ δ"
using assms mgu_always_unifies by force
lemma mgu_None_if_neq_ground:
assumes "t ≠ t'" "fv t = {}" "fv t' = {}"
shows "mgu t t' = None"
proof (rule ccontr)
assume "mgu t t' ≠ None"
then obtain δ where δ: "mgu t t' = Some δ" by auto
hence "t ⋅ δ = t" "t' ⋅ δ = t'" using assms subst_ground_ident by auto
thus False using assms(1) MGU_is_Unifier[OF mgu_gives_MGU[OF δ]] by auto
qed
lemma mgu_None_commutes:
"mgu s t = None ⟹ mgu t s = None"
using mgu_complete[of s t]
Unifier_in_unifiers_singleton[of s _ t]
Unifier_sym[of t _ s]
Unifier_in_unifiers_singleton[of t _ s]
mgu_sound[of t s]
unfolding is_imgu_def
by fastforce
lemma mgu_img_subterm_subst:
fixes δ::"('f,'v) subst" and s t u::"('f,'v) term"
assumes "mgu s t = Some δ" "u ∈ subterms⇩s⇩e⇩t (subst_range δ) - range Var"
shows "u ∈ ((subterms s ∪ subterms t) - range Var) ⋅⇩s⇩e⇩t δ"
proof -
define subterms_tuples::"('f,'v) equation list ⇒ ('f,'v) terms" where subtt_def:
"subterms_tuples ≡ λE. subterms⇩s⇩e⇩t (fst ` set E) ∪ subterms⇩s⇩e⇩t (snd ` set E)"
define subterms_img::"('f,'v) subst ⇒ ('f,'v) terms" where subti_def:
"subterms_img ≡ λd. subterms⇩s⇩e⇩t (subst_range d)"
define d where "d ≡ λv t. subst v t::('f,'v) subst"
define V where "V ≡ range Var::('f,'v) terms"
define R where "R ≡ λd::('f,'v) subst. ((subterms s ∪ subterms t) - V) ⋅⇩s⇩e⇩t d"
define M where "M ≡ λE d. subterms_tuples E ∪ subterms_img d"
define Q where "Q ≡ (λE d. M E d - V ⊆ R d - V)"
define Q' where "Q' ≡ (λE d d'. (M E d - V) ⋅⇩s⇩e⇩t d' ⊆ (R d - V) ⋅⇩s⇩e⇩t (d'::('f,'v) subst))"
have Q_subst: "Q (subst_list (subst v t') E) (subst_of ((v, t')#B))"
when v_fv: "v ∉ fv t'" and Q_assm: "Q ((Var v, t')#E) (subst_of B)"
for v t' E B
proof -
define E' where "E' ≡ subst_list (subst v t') E"
define B' where "B' ≡ subst_of ((v, t')#B)"
have E': "E' = subst_list (d v t') E"
and B': "B' = subst_of B ∘⇩s d v t'"
using subst_of_simps(3)[of "(v, t')"]
unfolding subst_def E'_def B'_def d_def by simp_all
have vt_img_subt: "subterms⇩s⇩e⇩t (subst_range (d v t')) = subterms t'"
and vt_dom: "subst_domain (d v t') = {v}"
using v_fv by (auto simp add: subst_domain_def d_def subst_def)
have *: "subterms u1 ⊆ subterms⇩s⇩e⇩t (fst ` set E)" "subterms u2 ⊆ subterms⇩s⇩e⇩t (snd ` set E)"
when "(u1,u2) ∈ set E" for u1 u2
using that by auto
have **: "subterms⇩s⇩e⇩t (d v t' ` (fv u ∩ subst_domain (d v t'))) ⊆ subterms t'"
for u::"('f,'v) term"
using vt_dom unfolding d_def by force
have 1: "subterms_tuples E' - V ⊆ (subterms t' - V) ∪ (subterms_tuples E - V ⋅⇩s⇩e⇩t d v t')"
(is "?A ⊆ ?B")
proof
fix u assume "u ∈ ?A"
then obtain u1 u2 where u12:
"(u1,u2) ∈ set E"
"u ∈ (subterms (u1 ⋅ (d v t')) - V) ∪ (subterms (u2 ⋅ (d v t')) - V)"
unfolding subtt_def subst_list_def E'_def d_def by moura
hence "u ∈ (subterms t' - V) ∪ (((subterms_tuples E) ⋅⇩s⇩e⇩t d v t') - V)"
using subterms_subst[of u1 "d v t'"] subterms_subst[of u2 "d v t'"]
*[OF u12(1)] **[of u1] **[of u2]
unfolding subtt_def subst_list_def by auto
moreover have
"(subterms_tuples E ⋅⇩s⇩e⇩t d v t') - V ⊆
(subterms_tuples E - V ⋅⇩s⇩e⇩t d v t') ∪ {t'}"
unfolding subst_def subtt_def V_def d_def by force
ultimately show "u ∈ ?B" using u12 v_fv by auto
qed
have 2: "subterms_img B' - V ⊆
(subterms t' - V) ∪ (subterms_img (subst_of B) - V ⋅⇩s⇩e⇩t d v t')"
using B' vt_img_subt subst_img_comp_subset'''[of "subst_of B" "d v t'"]
unfolding subti_def subst_def V_def by argo
have 3: "subterms_tuples ((Var v, t')#E) - V = (subterms t' - V) ∪ (subterms_tuples E - V)"
by (auto simp add: subst_def subtt_def V_def)
have "fv⇩s⇩e⇩t (subterms t' - V) ∩ subst_domain (d v t') = {}"
using v_fv vt_dom fv_subterms[of t'] by fastforce
hence 4: "subterms t' - V ⋅⇩s⇩e⇩t d v t' = subterms t' - V"
using set_subst_ident[of "subterms t' - range Var" "d v t'"] by (simp add: V_def)
have "M E' B' - V ⊆ M ((Var v, t')#E) (subst_of B) - V ⋅⇩s⇩e⇩t d v t'"
using 1 2 3 4 unfolding M_def by blast
moreover have "Q' ((Var v, t')#E) (subst_of B) (d v t')"
using Q_assm unfolding Q_def Q'_def by auto
moreover have "R (subst_of B) ⋅⇩s⇩e⇩t d v t' = R (subst_of ((v,t')#B))"
unfolding R_def d_def by auto
ultimately have
"M (subst_list (d v t') E) (subst_of ((v, t')#B)) - V ⊆ R (subst_of ((v, t')#B)) - V"
unfolding Q'_def E'_def B'_def d_def by blast
thus ?thesis unfolding Q_def M_def R_def d_def by blast
qed
have "u ∈ subterms s ∪ subterms t - V ⋅⇩s⇩e⇩t subst_of U"
when assms':
"unify E B = Some U"
"u ∈ subterms⇩s⇩e⇩t (subst_range (subst_of U)) - V"
"Q E (subst_of B)"
for E B U and T::"('f,'v) term list"
using assms'
proof (induction E B arbitrary: U rule: Unification.unify.induct)
case (1 B) thus ?case by (auto simp add: Q_def M_def R_def subti_def)
next
case (2 g X h Y E B U)
from "2.prems"(1) obtain E' where E':
"decompose (Fun g X) (Fun h Y) = Some E'"
"g = h" "length X = length Y" "E' = zip X Y"
"Unification.unify (E'@E) B = Some U"
by (auto split: option.splits)
moreover have "subterms_tuples (E'@E) ⊆ subterms_tuples ((Fun g X, Fun h Y)#E)"
proof
fix u assume "u ∈ subterms_tuples (E'@E)"
then obtain u1 u2 where u12: "(u1,u2) ∈ set (E'@E)" "u ∈ subterms u1 ∪ subterms u2"
unfolding subtt_def by fastforce
thus "u ∈ subterms_tuples ((Fun g X, Fun h Y)#E)"
proof (cases "(u1,u2) ∈ set E'")
case True
hence "subterms u1 ⊆ subterms (Fun g X)" "subterms u2 ⊆ subterms (Fun h Y)"
using E'(4) subterms_subset params_subterms subsetCE
by (metis set_zip_leftD, metis set_zip_rightD)
thus ?thesis using u12 unfolding subtt_def by auto
next
case False thus ?thesis using u12 unfolding subtt_def by fastforce
qed
qed
hence "Q (E'@E) (subst_of B)" using "2.prems"(3) unfolding Q_def M_def by blast
ultimately show ?case using "2.IH"[of E' U] "2.prems" by meson
next
case (3 v t' E B)
show ?case
proof (cases "t' = Var v")
case True thus ?thesis
using "3.prems" "3.IH"(1) unfolding Q_def M_def V_def subtt_def by auto
next
case False
hence 1: "v ∉ fv t'" using "3.prems"(1) by auto
hence "unify (subst_list (subst v t') E) ((v, t')#B) = Some U"
using False "3.prems"(1) by auto
thus ?thesis
using Q_subst[OF 1 "3.prems"(3)]
"3.IH"(2)[OF False 1 _ "3.prems"(2)]
by metis
qed
next
case (4 g X v E B U)
have 1: "v ∉ fv (Fun g X)" using "4.prems"(1) not_None_eq by fastforce
hence 2: "unify (subst_list (subst v (Fun g X)) E) ((v, Fun g X)#B) = Some U"
using "4.prems"(1) by auto
have 3: "Q ((Var v, Fun g X)#E) (subst_of B)"
using "4.prems"(3) unfolding Q_def M_def subtt_def by auto
show ?case
using Q_subst[OF 1 3] "4.IH"[OF 1 2 "4.prems"(2)]
by metis
qed
moreover obtain D where "unify [(s, t)] [] = Some D" "δ = subst_of D"
using assms(1) by (auto split: option.splits)
moreover have "Q [(s,t)] (subst_of [])"
unfolding Q_def M_def R_def subtt_def subti_def
by force
ultimately show ?thesis using assms(2) unfolding V_def by auto
qed
lemma mgu_img_consts:
fixes δ::"('f,'v) subst" and s t::"('f,'v) term" and c::'f and z::'v
assumes "mgu s t = Some δ" "Fun c [] ∈ subterms⇩s⇩e⇩t (subst_range δ)"
shows "Fun c [] ∈ subterms s ∪ subterms t"
proof -
obtain u where "u ∈ (subterms s ∪ subterms t) - range Var" "u ⋅ δ = Fun c []"
using mgu_img_subterm_subst[OF assms(1), of "Fun c []"] assms(2) by force
thus ?thesis by (cases u) auto
qed
lemma mgu_img_consts':
fixes δ::"('f,'v) subst" and s t::"('f,'v) term" and c::'f and z::'v
assumes "mgu s t = Some δ" "δ z = Fun c []"
shows "Fun c [] ⊑ s ∨ Fun c [] ⊑ t"
using mgu_img_consts[OF assms(1)] assms(2)
by (metis Un_iff in_subterms_Union subst_imgI term.distinct(1))
lemma mgu_img_composed_var_term:
fixes δ::"('f,'v) subst" and s t::"('f,'v) term" and f::'f and Z::"'v list"
assumes "mgu s t = Some δ" "Fun f (map Var Z) ∈ subterms⇩s⇩e⇩t (subst_range δ)"
shows "∃Z'. map δ Z' = map Var Z ∧ Fun f (map Var Z') ∈ subterms s ∪ subterms t"
proof -
obtain u where u: "u ∈ (subterms s ∪ subterms t) - range Var" "u ⋅ δ = Fun f (map Var Z)"
using mgu_img_subterm_subst[OF assms(1), of "Fun f (map Var Z)"] assms(2) by fastforce
then obtain T where T: "u = Fun f T" "map (λt. t ⋅ δ) T = map Var Z" by (cases u) auto
have "∀t ∈ set T. ∃x. t = Var x" using T(2) by (induct T arbitrary: Z) auto
then obtain Z' where Z': "map Var Z' = T" by (metis ex_map_conv)
hence "map δ Z' = map Var Z" using T(2) by (induct Z' arbitrary: T Z) auto
thus ?thesis using u(1) T(1) Z' by auto
qed
subsection ‹Lemmata: The "Inequality Lemmata"›
text ‹Subterm injectivity (a stronger injectivity property)›
definition subterm_inj_on where
"subterm_inj_on f A ≡ ∀x∈A. ∀y∈A. (∃v. v ⊑ f x ∧ v ⊑ f y) ⟶ x = y"
lemma subterm_inj_on_imp_inj_on: "subterm_inj_on f A ⟹ inj_on f A"
unfolding subterm_inj_on_def inj_on_def by fastforce
lemma subst_inj_on_is_bij_betw:
"inj_on θ (subst_domain θ) = bij_betw θ (subst_domain θ) (subst_range θ)"
unfolding inj_on_def bij_betw_def by auto
lemma subterm_inj_on_alt_def:
"subterm_inj_on f A ⟷
(inj_on f A ∧ (∀s ∈ f`A. ∀u ∈ f`A. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u))"
(is "?A ⟷ ?B")
unfolding subterm_inj_on_def inj_on_def by fastforce
lemma subterm_inj_on_alt_def':
"subterm_inj_on θ (subst_domain θ) ⟷
(inj_on θ (subst_domain θ) ∧
(∀s ∈ subst_range θ. ∀u ∈ subst_range θ. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u))"
(is "?A ⟷ ?B")
by (metis subterm_inj_on_alt_def subst_range.simps)
lemma subterm_inj_on_subset:
assumes "subterm_inj_on f A"
and "B ⊆ A"
shows "subterm_inj_on f B"
proof -
have "inj_on f A" "∀s∈f ` A. ∀u∈f ` A. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u"
using subterm_inj_on_alt_def[of f A] assms(1) by auto
moreover have "f ` B ⊆ f ` A" using assms(2) by auto
ultimately have "inj_on f B" "∀s∈f ` B. ∀u∈f ` B. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u"
using inj_on_subset[of f A] assms(2) by blast+
thus ?thesis by (metis subterm_inj_on_alt_def)
qed
lemma inj_subst_unif_consts:
fixes ℐ θ σ::"('f,'v) subst" and s t::"('f,'v) term"
assumes θ: "subterm_inj_on θ (subst_domain θ)" "∀x ∈ (fv s ∪ fv t) - X. ∃c. θ x = Fun c []"
"subterms⇩s⇩e⇩t (subst_range θ) ∩ (subterms s ∪ subterms t) = {}" "ground (subst_range θ)"
"subst_domain θ ∩ X = {}"
and ℐ: "ground (subst_range ℐ)" "subst_domain ℐ = subst_domain θ"
and unif: "Unifier σ (s ⋅ θ) (t ⋅ θ)"
shows "∃δ. Unifier δ (s ⋅ ℐ) (t ⋅ ℐ)"
proof -
let ?xs = "subst_domain θ"
let ?ys = "(fv s ∪ fv t) - ?xs"
have "∃δ::('f,'v) subst. s ⋅ δ = t ⋅ δ" by (metis subst_subst_compose unif)
then obtain δ::"('f,'v) subst" where δ: "mgu s t = Some δ"
using mgu_always_unifies by moura
have 1: "∃σ::('f,'v) subst. s ⋅ θ ⋅ σ = t ⋅ θ ⋅ σ" by (metis unif)
have 2: "⋀γ::('f,'v) subst. s ⋅ θ ⋅ γ = t ⋅ θ ⋅ γ ⟹ δ ≼⇩∘ θ ∘⇩s γ" using mgu_gives_MGU[OF δ] by simp
have 3: "⋀(z::'v) (c::'f). δ z = Fun c [] ⟹ Fun c [] ⊑ s ∨ Fun c [] ⊑ t"
by (rule mgu_img_consts'[OF δ])
have 4: "subst_domain δ ∩ range_vars δ = {}"
by (metis mgu_gives_wellformed_subst[OF δ] wf⇩s⇩u⇩b⇩s⇩t_def)
have 5: "subst_domain δ ∪ range_vars δ ⊆ fv s ∪ fv t"
by (metis mgu_gives_wellformed_MGU[OF δ] wf⇩M⇩G⇩U_def)
{ fix x and γ::"('f,'v) subst" assume "x ∈ subst_domain θ"
hence "(θ ∘⇩s γ) x = θ x"
using θ(4) ident_comp_subst_trm_if_disj[of γ θ]
unfolding range_vars_alt_def by fast
}
then obtain τ::"('f,'v) subst" where τ: "∀x ∈ subst_domain θ. θ x = (δ ∘⇩s τ) x" using 1 2 by moura
have *: "⋀x. x ∈ subst_domain δ ∩ subst_domain θ ⟹ ∃y ∈ ?ys. δ x = Var y"
proof -
fix x assume "x ∈ subst_domain δ ∩ ?xs"
hence x: "x ∈ subst_domain δ" "x ∈ subst_domain θ" by auto
then obtain c where c: "θ x = Fun c []" using θ(2,5) 5 by moura
hence *: "(δ ∘⇩s τ) x = Fun c []" using τ x by fastforce
hence **: "x ∈ subst_domain (δ ∘⇩s τ)" "Fun c [] ∈ subst_range (δ ∘⇩s τ)"
by (auto simp add: subst_domain_def)
have "δ x = Fun c [] ∨ (∃z. δ x = Var z ∧ τ z = Fun c [])"
by (rule subst_img_comp_subset_const'[OF *])
moreover have "δ x ≠ Fun c []"
proof (rule ccontr)
assume "¬δ x ≠ Fun c []"
hence "Fun c [] ⊑ s ∨ Fun c [] ⊑ t" using 3 by metis
moreover have "∀u ∈ subst_range θ. u ∉ subterms s ∪ subterms t"
using θ(3) by force
hence "Fun c [] ∉ subterms s ∪ subterms t"
by (metis c ‹ground (subst_range θ)›x(2) ground_subst_dom_iff_img)
ultimately show False by auto
qed
moreover have "∀x' ∈ subst_domain θ. δ x ≠ Var x'"
proof (rule ccontr)
assume "¬(∀x' ∈ subst_domain θ. δ x ≠ Var x')"
then obtain x' where x': "x' ∈ subst_domain θ" "δ x = Var x'" by moura
hence "τ x' = Fun c []" "(δ ∘⇩s τ) x = Fun c []" using * unfolding subst_compose_def by auto
moreover have "x ≠ x'"
using x(1) x'(2) 4
by (auto simp add: subst_domain_def)
moreover have "x' ∉ subst_domain δ"
using x'(2) mgu_eliminates_dom[OF δ]
by (metis (no_types) subst_elim_def subst_apply_term.simps(1) vars_iff_subterm_or_eq)
moreover have "(δ ∘⇩s τ) x = θ x" "(δ ∘⇩s τ) x' = θ x'" using τ x(2) x'(1) by auto
ultimately show False
using subterm_inj_on_imp_inj_on[OF θ(1)] *
by (simp add: inj_on_def subst_compose_def x'(2) subst_domain_def)
qed
ultimately show "∃y ∈ ?ys. δ x = Var y"
by (metis 5 x(2) subtermeqI' vars_iff_subtermeq DiffI Un_iff subst_fv_imgI sup.orderE)
qed
have **: "inj_on δ (subst_domain δ ∩ ?xs)"
proof (intro inj_onI)
fix x y assume *:
"x ∈ subst_domain δ ∩ subst_domain θ" "y ∈ subst_domain δ ∩ subst_domain θ" "δ x = δ y"
hence "(δ ∘⇩s τ) x = (δ ∘⇩s τ) y" unfolding subst_compose_def by auto
hence "θ x = θ y" using τ * by auto
thus "x = y" using inj_onD[OF subterm_inj_on_imp_inj_on[OF θ(1)]] *(1,2) by simp
qed
define α where "α = (λy'. if Var y' ∈ δ ` (subst_domain δ ∩ ?xs)
then Var ((inv_into (subst_domain δ ∩ ?xs) δ) (Var y'))
else Var y'::('f,'v) term)"
have a1: "Unifier (δ ∘⇩s α) s t" using mgu_gives_MGU[OF δ] by auto
define δ' where "δ' = δ ∘⇩s α"
have d1: "subst_domain δ' ⊆ ?ys"
proof
fix z assume z: "z ∈ subst_domain δ'"
have "z ∈ ?xs ⟹ z ∉ subst_domain δ'"
proof (cases "z ∈ subst_domain δ")
case True
moreover assume "z ∈ ?xs"
ultimately have z_in: "z ∈ subst_domain δ ∩ ?xs" by simp
then obtain y where y: "δ z = Var y" "y ∈ ?ys" using * by moura
hence "α y = Var ((inv_into (subst_domain δ ∩ ?xs) δ) (Var y))"
using α_def z_in by simp
hence "α y = Var z" by (metis y(1) z_in ** inv_into_f_eq)
hence "δ' z = Var z" using δ'_def y(1) subst_compose_def[of δ α] by simp
thus ?thesis by (simp add: subst_domain_def)
next
case False
hence "δ z = Var z" by (simp add: subst_domain_def)
moreover assume "z ∈ ?xs"
hence "α z = Var z" using α_def * by force
ultimately show ?thesis
using δ'_def subst_compose_def[of δ α]
by (simp add: subst_domain_def)
qed
moreover have "subst_domain α ⊆ range_vars δ"
unfolding δ'_def α_def range_vars_alt_def
by (auto simp add: subst_domain_def)
hence "subst_domain δ' ⊆ subst_domain δ ∪ range_vars δ"
using subst_domain_compose[of δ α] unfolding δ'_def by blast
ultimately show "z ∈ ?ys" using 5 z by auto
qed
have d2: "Unifier (δ' ∘⇩s ℐ) s t" using a1 δ'_def by auto
have d3: "ℐ ∘⇩s δ' ∘⇩s ℐ = δ' ∘⇩s ℐ"
proof -
{ fix z::'v assume z: "z ∈ ?xs"
then obtain u where u: "ℐ z = u" "fv u = {}" using ℐ by auto
hence "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = u" by (simp add: subst_compose subst_ground_ident)
moreover have "z ∉ subst_domain δ'" using d1 z by auto
hence "δ' z = Var z" by (simp add: subst_domain_def)
hence "(δ' ∘⇩s ℐ) z = u" using u(1) by (simp add: subst_compose)
ultimately have "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = (δ' ∘⇩s ℐ) z" by metis
} moreover {
fix z::'v assume "z ∈ ?ys"
hence "z ∉ subst_domain ℐ" using ℐ(2) by auto
hence "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = (δ' ∘⇩s ℐ) z" by (simp add: subst_compose subst_domain_def)
} moreover {
fix z::'v assume "z ∉ ?xs" "z ∉ ?ys"
hence "ℐ z = Var z" "δ' z = Var z" using ℐ(2) d1 by blast+
hence "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = (δ' ∘⇩s ℐ) z" by (simp add: subst_compose)
} ultimately show ?thesis by auto
qed
from d2 d3 have "Unifier (δ' ∘⇩s ℐ) (s ⋅ ℐ) (t ⋅ ℐ)" by (metis subst_subst_compose)
thus ?thesis by metis
qed
lemma inj_subst_unif_comp_terms:
fixes ℐ θ σ::"('f,'v) subst" and s t::"('f,'v) term"
assumes θ: "subterm_inj_on θ (subst_domain θ)" "ground (subst_range θ)"
"subterms⇩s⇩e⇩t (subst_range θ) ∩ (subterms s ∪ subterms t) = {}"
"(fv s ∪ fv t) - subst_domain θ ⊆ X"
and tfr: "∀f U. Fun f U ∈ subterms s ∪ subterms t ⟶ U = [] ∨ (∃u ∈ set U. u ∉ Var ` X)"
and ℐ: "ground (subst_range ℐ)" "subst_domain ℐ = subst_domain θ"
and unif: "Unifier σ (s ⋅ θ) (t ⋅ θ)"
shows "∃δ. Unifier δ (s ⋅ ℐ) (t ⋅ ℐ)"
proof -
let ?xs = "subst_domain θ"
let ?ys = "(fv s ∪ fv t) - ?xs"
have "ground (subst_range θ)" using θ(2) by auto
have "∃δ::('f,'v) subst. s ⋅ δ = t ⋅ δ" by (metis subst_subst_compose unif)
then obtain δ::"('f,'v) subst" where δ: "mgu s t = Some δ"
using mgu_always_unifies by moura
have 1: "∃σ::('f,'v) subst. s ⋅ θ ⋅ σ = t ⋅ θ ⋅ σ" by (metis unif)
have 2: "⋀γ::('f,'v) subst. s ⋅ θ ⋅ γ = t ⋅ θ ⋅ γ ⟹ δ ≼⇩∘ θ ∘⇩s γ" using mgu_gives_MGU[OF δ] by simp
have 3: "⋀(z::'v) (c::'f). Fun c [] ⊑ δ z ⟹ Fun c [] ⊑ s ∨ Fun c [] ⊑ t"
using mgu_img_consts[OF δ] by force
have 4: "subst_domain δ ∩ range_vars δ = {}"
using mgu_gives_wellformed_subst[OF δ]
by (metis wf⇩s⇩u⇩b⇩s⇩t_def)
have 5: "subst_domain δ ∪ range_vars δ ⊆ fv s ∪ fv t"
using mgu_gives_wellformed_MGU[OF δ]
by (metis wf⇩M⇩G⇩U_def)
{ fix x and γ::"('f,'v) subst" assume "x ∈ subst_domain θ"
hence "(θ ∘⇩s γ) x = θ x"
using ‹ground (subst_range θ)› ident_comp_subst_trm_if_disj[of γ θ x]
unfolding range_vars_alt_def by blast
}
then obtain τ::"('f,'v) subst" where τ: "∀x ∈ subst_domain θ. θ x = (δ ∘⇩s τ) x" using 1 2 by moura
have ***: "⋀x. x ∈ subst_domain δ ∩ subst_domain θ ⟹ fv (δ x) ⊆ ?ys"
proof -
fix x assume "x ∈ subst_domain δ ∩ ?xs"
hence x: "x ∈ subst_domain δ" "x ∈ subst_domain θ" by auto
moreover have "¬(∃x' ∈ ?xs. x' ∈ fv (δ x))"
proof (rule ccontr)
assume "¬¬(∃x' ∈ ?xs. x' ∈ fv (δ x))"
then obtain x' where x': "x' ∈ fv (δ x)" "x' ∈ ?xs" by metis
have "x ≠ x'" "x' ∉ subst_domain δ" "δ x' = Var x'"
using 4 x(1) x'(1) unfolding range_vars_alt_def by auto
hence "(δ ∘⇩s τ) x' ⊑ (δ ∘⇩s τ) x" "τ x' = (δ ∘⇩s τ) x'"
using τ x(2) x'(2)
by (metis subst_compose subst_mono vars_iff_subtermeq x'(1),
metis subst_apply_term.simps(1) subst_compose_def)
hence "θ x' ⊑ θ x" using τ x(2) x'(2) by auto
thus False
using θ(1) x'(2) x(2) ‹x ≠ x'›
unfolding subterm_inj_on_def
by (meson subtermeqI')
qed
ultimately show "fv (δ x) ⊆ ?ys"
using 5 subst_dom_vars_in_subst[of x δ] subst_fv_imgI[of δ x]
by blast
qed
have **: "inj_on δ (subst_domain δ ∩ ?xs)"
proof (intro inj_onI)
fix x y assume *:
"x ∈ subst_domain δ ∩ subst_domain θ" "y ∈ subst_domain δ ∩ subst_domain θ" "δ x = δ y"
hence "(δ ∘⇩s τ) x = (δ ∘⇩s τ) y" unfolding subst_compose_def by auto
hence "θ x = θ y" using τ * by auto
thus "x = y" using inj_onD[OF subterm_inj_on_imp_inj_on[OF θ(1)]] *(1,2) by simp
qed
have *: "⋀x. x ∈ subst_domain δ ∩ subst_domain θ ⟹ ∃y ∈ ?ys. δ x = Var y"
proof (rule ccontr)
fix xi assume xi_assms: "xi ∈ subst_domain δ ∩ subst_domain θ" "¬(∃y ∈ ?ys. δ xi = Var y)"
hence xi_θ: "xi ∈ subst_domain θ" and δ_xi_comp: "¬(∃y. δ xi = Var y)"
using ***[of xi] 5 by auto
then obtain f T where f: "δ xi = Fun f T" by (cases "δ xi") moura
have "∃g Y'. Y' ≠ [] ∧ Fun g (map Var Y') ⊑ δ xi ∧ set Y' ⊆ ?ys"
proof -
have "∀c. Fun c [] ⊑ δ xi ⟶ Fun c [] ⊑ θ xi"
using τ xi_θ by (metis const_subterm_subst subst_compose)
hence 1: "∀c. ¬(Fun c [] ⊑ δ xi)"
using 3[of _ xi] xi_θ θ(3)
by auto
have "¬(∃x. δ xi = Var x)" using f by auto
hence "∃g S. Fun g S ⊑ δ xi ∧ (∀s ∈ set S. (∃c. s = Fun c []) ∨ (∃x. s = Var x))"
using nonvar_term_has_composed_shallow_term[of "δ xi"] by auto
then obtain g S where gS: "Fun g S ⊑ δ xi" "∀s ∈ set S. (∃c. s = Fun c []) ∨ (∃x. s = Var x)"
by moura
have "∀s ∈ set S. ∃x. s = Var x"
using 1 term.order_trans gS
by (metis (no_types, lifting) UN_I term.order_refl subsetCE subterms.simps(2) sup_ge2)
then obtain S' where 2: "map Var S' = S" by (metis ex_map_conv)
have "S ≠ []" using 1 term.order_trans[OF _ gS(1)] by fastforce
hence 3: "S' ≠ []" "Fun g (map Var S') ⊑ δ xi" using gS(1) 2 by auto
have "set S' ⊆ fv (Fun g (map Var S'))" by simp
hence 4: "set S' ⊆ fv (δ xi)" using 3(2) fv_subterms by force
show ?thesis using ***[OF xi_assms(1)] 2 3 4 by auto
qed
then obtain g Y' where g: "Y' ≠ []" "Fun g (map Var Y') ⊑ δ xi" "set Y' ⊆ ?ys" by moura
then obtain X where X: "map δ X = map Var Y'" "Fun g (map Var X) ∈ subterms s ∪ subterms t"
using mgu_img_composed_var_term[OF δ, of g Y'] by force
hence "∃(u::('f,'v) term) ∈ set (map Var X). u ∉ Var ` ?ys"
using θ(4) tfr g(1) by fastforce
then obtain j where j: "j < length X" "X ! j ∉ ?ys"
by (metis image_iff[of _ Var "fv s ∪ fv t - subst_domain θ"] nth_map[of _ X Var]
in_set_conv_nth[of _ "map Var X"] length_map[of Var X])
define yj' where yj': "yj' ≡ Y' ! j"
define xj where xj: "xj ≡ X ! j"
have "xj ∈ fv s ∪ fv t"
using j X(1) g(3) 5 xj yj'
by (metis length_map nth_map term.simps(1) in_set_conv_nth le_supE subsetCE subst_domI)
hence xj_θ: "xj ∈ subst_domain θ" using j unfolding xj by simp
have len: "length X = length Y'" by (rule map_eq_imp_length_eq[OF X(1)])
have "Var yj' ⊑ δ xi"
using term.order_trans[OF _ g(2)] j(1) len unfolding yj' by auto
hence "τ yj' ⊑ θ xi"
using τ xi_θ by (metis subst_apply_term.simps(1) subst_compose_def subst_mono)
moreover have δ_xj_var: "Var yj' = δ xj"
using X(1) len j(1) nth_map
unfolding xj yj' by metis
hence "τ yj' = θ xj" using τ xj_θ by (metis subst_apply_term.simps(1) subst_compose_def)
moreover have "xi ≠ xj" using δ_xi_comp δ_xj_var by auto
ultimately show False using θ(1) xi_θ xj_θ unfolding subterm_inj_on_def by blast
qed
define α where "α = (λy'. if Var y' ∈ δ ` (subst_domain δ ∩ ?xs)
then Var ((inv_into (subst_domain δ ∩ ?xs) δ) (Var y'))
else Var y'::('f,'v) term)"
have a1: "Unifier (δ ∘⇩s α) s t" using mgu_gives_MGU[OF δ] by auto
define δ' where "δ' = δ ∘⇩s α"
have d1: "subst_domain δ' ⊆ ?ys"
proof
fix z assume z: "z ∈ subst_domain δ'"
have "z ∈ ?xs ⟹ z ∉ subst_domain δ'"
proof (cases "z ∈ subst_domain δ")
case True
moreover assume "z ∈ ?xs"
ultimately have z_in: "z ∈ subst_domain δ ∩ ?xs" by simp
then obtain y where y: "δ z = Var y" "y ∈ ?ys" using * by moura
hence "α y = Var ((inv_into (subst_domain δ ∩ ?xs) δ) (Var y))"
using α_def z_in by simp
hence "α y = Var z" by (metis y(1) z_in ** inv_into_f_eq)
hence "δ' z = Var z" using δ'_def y(1) subst_compose_def[of δ α] by simp
thus ?thesis by (simp add: subst_domain_def)
next
case False
hence "δ z = Var z" by (simp add: subst_domain_def)
moreover assume "z ∈ ?xs"
hence "α z = Var z" using α_def * by force
ultimately show ?thesis using δ'_def subst_compose_def[of δ α] by (simp add: subst_domain_def)
qed
moreover have "subst_domain α ⊆ range_vars δ"
unfolding δ'_def α_def range_vars_alt_def subst_domain_def
by auto
hence "subst_domain δ' ⊆ subst_domain δ ∪ range_vars δ"
using subst_domain_compose[of δ α]
unfolding δ'_def by blast
ultimately show "z ∈ ?ys" using 5 z by blast
qed
have d2: "Unifier (δ' ∘⇩s ℐ) s t" using a1 δ'_def by auto
have d3: "ℐ ∘⇩s δ' ∘⇩s ℐ = δ' ∘⇩s ℐ"
proof -
{ fix z::'v assume z: "z ∈ ?xs"
then obtain u where u: "ℐ z = u" "fv u = {}" using ℐ by auto
hence "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = u" by (simp add: subst_compose subst_ground_ident)
moreover have "z ∉ subst_domain δ'" using d1 z by auto
hence "δ' z = Var z" by (simp add: subst_domain_def)
hence "(δ' ∘⇩s ℐ) z = u" using u(1) by (simp add: subst_compose)
ultimately have "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = (δ' ∘⇩s ℐ) z" by metis
} moreover {
fix z::'v assume "z ∈ ?ys"
hence "z ∉ subst_domain ℐ" using ℐ(2) by auto
hence "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = (δ' ∘⇩s ℐ) z" by (simp add: subst_compose subst_domain_def)
} moreover {
fix z::'v assume "z ∉ ?xs" "z ∉ ?ys"
hence "ℐ z = Var z" "δ' z = Var z" using ℐ(2) d1 by blast+
hence "(ℐ ∘⇩s δ' ∘⇩s ℐ) z = (δ' ∘⇩s ℐ) z" by (simp add: subst_compose)
} ultimately show ?thesis by auto
qed
from d2 d3 have "Unifier (δ' ∘⇩s ℐ) (s ⋅ ℐ) (t ⋅ ℐ)" by (metis subst_subst_compose)
thus ?thesis by metis
qed
context
begin
private lemma sat_ineq_subterm_inj_subst_aux:
fixes ℐ::"('f,'v) subst"
assumes "Unifier σ (s ⋅ ℐ) (t ⋅ ℐ)" "ground (subst_range ℐ)"
"(fv s ∪ fv t) - X ⊆ subst_domain ℐ" "subst_domain ℐ ∩ X = {}"
shows "∃δ::('f,'v) subst. subst_domain δ = X ∧ ground (subst_range δ) ∧ s ⋅ δ ⋅ ℐ = t ⋅ δ ⋅ ℐ"
proof -
have "∃σ. Unifier σ (s ⋅ ℐ) (t ⋅ ℐ) ∧ interpretation⇩s⇩u⇩b⇩s⇩t σ"
proof -
obtain ℐ'::"('f,'v) subst" where *: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ'"
using interpretation_subst_exists by metis
hence "Unifier (σ ∘⇩s ℐ') (s ⋅ ℐ) (t ⋅ ℐ)" using assms(1) by simp
thus ?thesis using * interpretation_comp by blast
qed
then obtain σ' where σ': "Unifier σ' (s ⋅ ℐ) (t ⋅ ℐ)" "interpretation⇩s⇩u⇩b⇩s⇩t σ'" by moura
define σ'' where "σ'' = rm_vars (UNIV - X) σ'"
have *: "fv (s ⋅ ℐ) ⊆ X" "fv (t ⋅ ℐ) ⊆ X"
using assms(2,3) subst_fv_unfold_ground_img[of ℐ]
unfolding range_vars_alt_def
by (simp_all add: Diff_subset_conv Un_commute)
hence **: "subst_domain σ'' = X" "ground (subst_range σ'')"
using rm_vars_img_subset[of "UNIV - X" σ'] rm_vars_dom[of "UNIV - X" σ'] σ'(2)
unfolding σ''_def by auto
hence "⋀t. t ⋅ ℐ ⋅ σ'' = t ⋅ σ'' ⋅ ℐ"
using subst_eq_if_disjoint_vars_ground[OF _ _ assms(2)] assms(4) by blast
moreover have "Unifier σ'' (s ⋅ ℐ) (t ⋅ ℐ)"
using Unifier_dom_restrict[OF σ'(1)] σ''_def * by blast
ultimately show ?thesis using ** by auto
qed
text ‹
The "inequality lemma": This lemma gives sufficient syntactic conditions for finding substitutions
‹θ› under which terms ‹s› and ‹t› are not unifiable.
This is useful later when establishing the typing results since we there want to find well-typed
solutions to inequality constraints / "negative checks" constraints, and this lemma gives
conditions for protocols under which such constraints are well-typed satisfiable if satisfiable.
›
lemma sat_ineq_subterm_inj_subst:
fixes θ ℐ δ::"('f,'v) subst"
assumes θ: "subterm_inj_on θ (subst_domain θ)"
"ground (subst_range θ)"
"subst_domain θ ∩ X = {}"
"subterms⇩s⇩e⇩t (subst_range θ) ∩ (subterms s ∪ subterms t) = {}"
"(fv s ∪ fv t) - subst_domain θ ⊆ X"
and tfr: "(∀x ∈ (fv s ∪ fv t) - X. ∃c. θ x = Fun c []) ∨
(∀f U. Fun f U ∈ subterms s ∪ subterms t ⟶ U = [] ∨ (∃u ∈ set U. u ∉ Var ` X))"
and ℐ: "∀δ::('f,'v) subst. subst_domain δ = X ∧ ground (subst_range δ) ⟶ s ⋅ δ ⋅ ℐ ≠ t ⋅ δ ⋅ ℐ"
"(fv s ∪ fv t) - X ⊆ subst_domain ℐ" "subst_domain ℐ ∩ X = {}" "ground (subst_range ℐ)"
"subst_domain ℐ = subst_domain θ"
and δ: "subst_domain δ = X" "ground (subst_range δ)"
shows "s ⋅ δ ⋅ θ ≠ t ⋅ δ ⋅ θ"
proof -
have "∀σ. ¬Unifier σ (s ⋅ ℐ) (t ⋅ ℐ)"
by (metis ℐ(1) sat_ineq_subterm_inj_subst_aux[OF _ ℐ(4,2,3)])
hence "¬Unifier δ (s ⋅ θ) (t ⋅ θ)"
using inj_subst_unif_consts[OF θ(1) _ θ(4,2,3) ℐ(4,5)]
inj_subst_unif_comp_terms[OF θ(1,2,4,5) _ ℐ(4,5)]
tfr
by metis
moreover have "subst_domain δ ∩ subst_domain θ = {}" using θ(2,3) δ(1) by auto
ultimately show ?thesis using δ subst_eq_if_disjoint_vars_ground[OF _ θ(2) δ(2)] by metis
qed
end
lemma ineq_subterm_inj_cond_subst:
assumes "X ∩ range_vars θ = {}"
and "∀f T. Fun f T ∈ subterms⇩s⇩e⇩t S ⟶ T = [] ∨ (∃u ∈ set T. u ∉ Var`X)"
shows "∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (S ⋅⇩s⇩e⇩t θ) ⟶ T = [] ∨ (∃u ∈ set T. u ∉ Var`X)"
proof (intro allI impI)
let ?M = "λS. subterms⇩s⇩e⇩t S ⋅⇩s⇩e⇩t θ"
let ?N = "λS. subterms⇩s⇩e⇩t (θ ` (fv⇩s⇩e⇩t S ∩ subst_domain θ))"
fix f T assume "Fun f T ∈ subterms⇩s⇩e⇩t (S ⋅⇩s⇩e⇩t θ)"
hence 1: "Fun f T ∈ ?M S ∨ Fun f T ∈ ?N S"
using subterms_subst[of _ θ] by auto
have 2: "Fun f T ∈ subterms⇩s⇩e⇩t (subst_range θ) ⟹ ∀u ∈ set T. u ∉ Var`X"
using fv_subset_subterms[of "Fun f T" "subst_range θ"] assms(1)
unfolding range_vars_alt_def by force
have 3: "∀x ∈ subst_domain θ. θ x ∉ Var`X"
proof
fix x assume "x ∈ subst_domain θ"
hence "fv (θ x) ⊆ range_vars θ"
using subst_dom_vars_in_subst subst_fv_imgI
unfolding range_vars_alt_def by auto
thus "θ x ∉ Var`X" using assms(1) by auto
qed
show "T = [] ∨ (∃s ∈ set T. s ∉ Var`X)" using 1
proof
assume "Fun f T ∈ ?M S"
then obtain u where u: "u ∈ subterms⇩s⇩e⇩t S" "u ⋅ θ = Fun f T" by fastforce
show ?thesis
proof (cases u)
case (Var x)
hence "Fun f T ∈ subst_range θ" using u(2) by (simp add: subst_domain_def)
hence "∀u ∈ set T. u ∉ Var`X" using 2 by force
thus ?thesis by auto
next
case (Fun g S)
hence "S = [] ∨ (∃u ∈ set S. u ∉ Var`X)" using assms(2) u(1) by metis
thus ?thesis
proof
assume "S = []" thus ?thesis using u(2) Fun by simp
next
assume "∃u ∈ set S. u ∉ Var`X"
then obtain u' where u': "u' ∈ set S" "u' ∉ Var`X" by moura
hence "u' ⋅ θ ∈ set T" using u(2) Fun by auto
thus ?thesis using u'(2) 3 by (cases u') force+
qed
qed
next
assume "Fun f T ∈ ?N S"
thus ?thesis using 2 by force
qed
qed
subsection ‹Lemmata: Sufficient Conditions for Term Matching›
text ‹Injective substitutions from variables to variables are invertible›
definition subst_var_inv where
"subst_var_inv δ X ≡ (λx. if Var x ∈ δ ` X then Var ((inv_into X δ) (Var x)) else Var x)"
lemma inj_var_ran_subst_is_invertible:
assumes δ_inj_on_t: "inj_on δ (fv t)"
and δ_var_on_t: "δ ` fv t ⊆ range Var"
shows "t = t ⋅ δ ∘⇩s subst_var_inv δ (fv t)"
proof -
have "δ x ⋅ subst_var_inv δ (fv t) = Var x" when x: "x ∈ fv t" for x
proof -
obtain y where y: "δ x = Var y" using x δ_var_on_t by auto
hence "Var y ∈ δ ` (fv t)" using x by simp
thus ?thesis using y inv_into_f_eq[OF δ_inj_on_t x y] unfolding subst_var_inv_def by simp
qed
thus ?thesis by (simp add: subst_compose_def trm_subst_ident'')
qed
text ‹Sufficient conditions for matching unifiable terms›
lemma inj_var_ran_unifiable_has_subst_match:
assumes "t ⋅ δ = s ⋅ δ" "inj_on δ (fv t)" "δ ` fv t ⊆ range Var"
shows "t = s ⋅ δ ∘⇩s subst_var_inv δ (fv t)"
using assms inj_var_ran_subst_is_invertible by fastforce
end
Theory Intruder_Deduction
section ‹Dolev-Yao Intruder Model›
theory Intruder_Deduction
imports Messages More_Unification
begin
subsection ‹Syntax for the Intruder Deduction Relations›
consts INTRUDER_SYNTH::"('f,'v) terms ⇒ ('f,'v) term ⇒ bool" (infix "⊢⇩c" 50)
consts INTRUDER_DEDUCT::"('f,'v) terms ⇒ ('f,'v) term ⇒ bool" (infix "⊢" 50)
subsection ‹Intruder Model Locale›
text ‹
The intruder model is parameterized over arbitrary function symbols (e.g, cryptographic operators)
and variables. It requires three functions:
- ‹arity› that assigns an arity to each function symbol.
- ‹public› that partitions the function symbols into those that will be available to the intruder
and those that will not.
- ‹Ana›, the analysis interface, that defines how messages can be decomposed (e.g., decryption).
›
locale intruder_model =
fixes arity :: "'fun ⇒ nat"
and public :: "'fun ⇒ bool"
and Ana :: "('fun,'var) term ⇒ (('fun,'var) term list × ('fun,'var) term list)"
assumes Ana_keys_fv: "⋀t K R. Ana t = (K,R) ⟹ fv⇩s⇩e⇩t (set K) ⊆ fv t"
and Ana_keys_wf: "⋀t k K R f T.
Ana t = (K,R) ⟹ (⋀g S. Fun g S ⊑ t ⟹ length S = arity g)
⟹ k ∈ set K ⟹ Fun f T ⊑ k ⟹ length T = arity f"
and Ana_var[simp]: "⋀x. Ana (Var x) = ([],[])"
and Ana_fun_subterm: "⋀f T K R. Ana (Fun f T) = (K,R) ⟹ set R ⊆ set T"
and Ana_subst: "⋀t δ K R. ⟦Ana t = (K,R); K ≠ [] ∨ R ≠ []⟧ ⟹ Ana (t ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ,R ⋅⇩l⇩i⇩s⇩t δ)"
begin
lemma Ana_subterm: assumes "Ana t = (K,T)" shows "set T ⊂ subterms t"
using assms
by (cases t)
(simp add: psubsetI,
metis Ana_fun_subterm Fun_gt_params UN_I term.order_refl
params_subterms psubsetI subset_antisym subset_trans)
lemma Ana_subterm': "s ∈ set (snd (Ana t)) ⟹ s ⊑ t"
using Ana_subterm by (cases "Ana t") auto
lemma Ana_vars: assumes "Ana t = (K,M)" shows "fv⇩s⇩e⇩t (set K) ⊆ fv t" "fv⇩s⇩e⇩t (set M) ⊆ fv t"
by (rule Ana_keys_fv[OF assms]) (use Ana_subterm[OF assms] subtermeq_vars_subset in auto)
abbreviation 𝒱 where "𝒱 ≡ UNIV::'var set"
abbreviation Σn ("Σ⇧_") where "Σ⇧n ≡ {f::'fun. arity f = n}"
abbreviation Σnpub ("Σ⇩p⇩u⇩b⇧_") where "Σ⇩p⇩u⇩b⇧n ≡ {f. public f} ∩ Σ⇧n"
abbreviation Σnpriv ("Σ⇩p⇩r⇩i⇩v⇧_") where "Σ⇩p⇩r⇩i⇩v⇧n ≡ {f. ¬public f} ∩ Σ⇧n"
abbreviation Σ⇩p⇩u⇩b where "Σ⇩p⇩u⇩b ≡ (⋃n. Σ⇩p⇩u⇩b⇧n)"
abbreviation Σ⇩p⇩r⇩i⇩v where "Σ⇩p⇩r⇩i⇩v ≡ (⋃n. Σ⇩p⇩r⇩i⇩v⇧n)"
abbreviation Σ where "Σ ≡ (⋃n. Σ⇧n)"
abbreviation 𝒞 where "𝒞 ≡ Σ⇧0"
abbreviation 𝒞⇩p⇩u⇩b where "𝒞⇩p⇩u⇩b ≡ {f. public f} ∩ 𝒞"
abbreviation 𝒞⇩p⇩r⇩i⇩v where "𝒞⇩p⇩r⇩i⇩v ≡ {f. ¬public f} ∩ 𝒞"
abbreviation Σ⇩f where "Σ⇩f ≡ Σ - 𝒞"
abbreviation Σ⇩f⇩p⇩u⇩b where "Σ⇩f⇩p⇩u⇩b ≡ Σ⇩f ∩ Σ⇩p⇩u⇩b"
abbreviation Σ⇩f⇩p⇩r⇩i⇩v where "Σ⇩f⇩p⇩r⇩i⇩v ≡ Σ⇩f ∩ Σ⇩p⇩r⇩i⇩v"
lemma disjoint_fun_syms: "Σ⇩f ∩ 𝒞 = {}" by auto
lemma id_union_univ: "Σ⇩f ∪ 𝒞 = UNIV" "Σ = UNIV" by auto
lemma const_arity_eq_zero[dest]: "c ∈ 𝒞 ⟹ arity c = 0" by simp
lemma const_pub_arity_eq_zero[dest]: "c ∈ 𝒞⇩p⇩u⇩b ⟹ arity c = 0 ∧ public c" by simp
lemma const_priv_arity_eq_zero[dest]: "c ∈ 𝒞⇩p⇩r⇩i⇩v ⟹ arity c = 0 ∧ ¬public c" by simp
lemma fun_arity_gt_zero[dest]: "f ∈ Σ⇩f ⟹ arity f > 0" by fastforce
lemma pub_fun_public[dest]: "f ∈ Σ⇩f⇩p⇩u⇩b ⟹ public f" by fastforce
lemma pub_fun_arity_gt_zero[dest]: "f ∈ Σ⇩f⇩p⇩u⇩b ⟹ arity f > 0" by fastforce
lemma Σ⇩f_unfold: "Σ⇩f = {f::'fun. arity f > 0}" by auto
lemma 𝒞_unfold: "𝒞 = {f::'fun. arity f = 0}" by auto
lemma 𝒞pub_unfold: "𝒞⇩p⇩u⇩b = {f::'fun. arity f = 0 ∧ public f}" by auto
lemma 𝒞priv_unfold: "𝒞⇩p⇩r⇩i⇩v = {f::'fun. arity f = 0 ∧ ¬public f}" by auto
lemma Σnpub_unfold: "(Σ⇩p⇩u⇩b⇧n) = {f::'fun. arity f = n ∧ public f}" by auto
lemma Σnpriv_unfold: "(Σ⇩p⇩r⇩i⇩v⇧n) = {f::'fun. arity f = n ∧ ¬public f}" by auto
lemma Σfpub_unfold: "Σ⇩f⇩p⇩u⇩b = {f::'fun. arity f > 0 ∧ public f}" by auto
lemma Σfpriv_unfold: "Σ⇩f⇩p⇩r⇩i⇩v = {f::'fun. arity f > 0 ∧ ¬public f}" by auto
lemma Σn_m_eq: "⟦(Σ⇧n) ≠ {}; (Σ⇧n) = (Σ⇧m)⟧ ⟹ n = m" by auto
subsection ‹Term Well-formedness›
definition "wf⇩t⇩r⇩m t ≡ ∀f T. Fun f T ⊑ t ⟶ length T = arity f"
abbreviation "wf⇩t⇩r⇩m⇩s T ≡ ∀t ∈ T. wf⇩t⇩r⇩m t"
lemma Ana_keys_wf': "Ana t = (K,T) ⟹ wf⇩t⇩r⇩m t ⟹ k ∈ set K ⟹ wf⇩t⇩r⇩m k"
using Ana_keys_wf unfolding wf⇩t⇩r⇩m_def by metis
lemma wf_trm_Var[simp]: "wf⇩t⇩r⇩m (Var x)" unfolding wf⇩t⇩r⇩m_def by simp
lemma wf_trm_subst_range_Var[simp]: "wf⇩t⇩r⇩m⇩s (subst_range Var)" by simp
lemma wf_trm_subst_range_iff: "(∀x. wf⇩t⇩r⇩m (θ x)) ⟷ wf⇩t⇩r⇩m⇩s (subst_range θ)"
by force
lemma wf_trm_subst_rangeD: "wf⇩t⇩r⇩m⇩s (subst_range θ) ⟹ wf⇩t⇩r⇩m (θ x)"
by (metis wf_trm_subst_range_iff)
lemma wf_trm_subst_rangeI[intro]:
"(⋀x. wf⇩t⇩r⇩m (δ x)) ⟹ wf⇩t⇩r⇩m⇩s (subst_range δ)"
by (metis wf_trm_subst_range_iff)
lemma wf_trmI[intro]:
assumes "⋀t. t ∈ set T ⟹ wf⇩t⇩r⇩m t" "length T = arity f"
shows "wf⇩t⇩r⇩m (Fun f T)"
using assms unfolding wf⇩t⇩r⇩m_def by auto
lemma wf_trm_subterm: "⟦wf⇩t⇩r⇩m t; s ⊏ t⟧ ⟹ wf⇩t⇩r⇩m s"
unfolding wf⇩t⇩r⇩m_def by (induct t) auto
lemma wf_trm_subtermeq:
assumes "wf⇩t⇩r⇩m t" "s ⊑ t"
shows "wf⇩t⇩r⇩m s"
proof (cases "s = t")
case False thus "wf⇩t⇩r⇩m s" using assms(2) wf_trm_subterm[OF assms(1)] by simp
qed (metis assms(1))
lemma wf_trm_param:
assumes "wf⇩t⇩r⇩m (Fun f T)" "t ∈ set T"
shows "wf⇩t⇩r⇩m t"
by (meson assms subtermeqI'' wf_trm_subtermeq)
lemma wf_trm_param_idx:
assumes "wf⇩t⇩r⇩m (Fun f T)"
and "i < length T"
shows "wf⇩t⇩r⇩m (T ! i)"
using wf_trm_param[OF assms(1), of "T ! i"] assms(2)
by fastforce
lemma wf_trm_subst:
assumes "wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "wf⇩t⇩r⇩m t = wf⇩t⇩r⇩m (t ⋅ δ)"
proof
show "wf⇩t⇩r⇩m t ⟹ wf⇩t⇩r⇩m (t ⋅ δ)"
proof (induction t)
case (Fun f T)
hence "⋀t. t ∈ set T ⟹ wf⇩t⇩r⇩m t"
by (meson wf⇩t⇩r⇩m_def Fun_param_is_subterm term.order_trans)
hence "⋀t. t ∈ set T ⟹ wf⇩t⇩r⇩m (t ⋅ δ)" using Fun.IH by auto
moreover have "length (map (λt. t ⋅ δ) T) = arity f"
using Fun.prems unfolding wf⇩t⇩r⇩m_def by auto
ultimately show ?case by fastforce
qed (simp add: wf_trm_subst_rangeD[OF assms])
show "wf⇩t⇩r⇩m (t ⋅ δ) ⟹ wf⇩t⇩r⇩m t"
proof (induction t)
case (Fun f T)
hence "wf⇩t⇩r⇩m t" when "t ∈ set (map (λs. s ⋅ δ) T)" for t
by (metis that wf⇩t⇩r⇩m_def Fun_param_is_subterm term.order_trans subst_apply_term.simps(2))
hence "wf⇩t⇩r⇩m t" when "t ∈ set T" for t using that Fun.IH by auto
moreover have "length (map (λt. t ⋅ δ) T) = arity f"
using Fun.prems unfolding wf⇩t⇩r⇩m_def by auto
ultimately show ?case by fastforce
qed (simp add: assms)
qed
lemma wf_trm_subst_singleton:
assumes "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m t'" shows "wf⇩t⇩r⇩m (t ⋅ Var(v := t'))"
proof -
have "wf⇩t⇩r⇩m ((Var(v := t')) w)" for w using assms(2) unfolding wf⇩t⇩r⇩m_def by simp
thus ?thesis using assms(1) wf_trm_subst[of "Var(v := t')" t, OF wf_trm_subst_rangeI] by simp
qed
lemma wf_trm_subst_rm_vars:
assumes "wf⇩t⇩r⇩m (t ⋅ δ)"
shows "wf⇩t⇩r⇩m (t ⋅ rm_vars X δ)"
using assms
proof (induction t)
case (Fun f T)
have "wf⇩t⇩r⇩m (t ⋅ δ)" when "t ∈ set T" for t
using that wf_trm_param[of f "map (λt. t ⋅ δ) T"] Fun.prems
by auto
hence "wf⇩t⇩r⇩m (t ⋅ rm_vars X δ)" when "t ∈ set T" for t using that Fun.IH by simp
moreover have "length T = arity f" using Fun.prems unfolding wf⇩t⇩r⇩m_def by auto
ultimately show ?case unfolding wf⇩t⇩r⇩m_def by auto
qed simp
lemma wf_trm_subst_rm_vars': "wf⇩t⇩r⇩m (δ v) ⟹ wf⇩t⇩r⇩m (rm_vars X δ v)"
by auto
lemma wf_trms_subst:
assumes "wf⇩t⇩r⇩m⇩s (subst_range δ)" "wf⇩t⇩r⇩m⇩s M"
shows "wf⇩t⇩r⇩m⇩s (M ⋅⇩s⇩e⇩t δ)"
by (metis (no_types, lifting) assms imageE wf_trm_subst)
lemma wf_trms_subst_rm_vars:
assumes "wf⇩t⇩r⇩m⇩s (M ⋅⇩s⇩e⇩t δ)"
shows "wf⇩t⇩r⇩m⇩s (M ⋅⇩s⇩e⇩t rm_vars X δ)"
using assms wf_trm_subst_rm_vars by blast
lemma wf_trms_subst_rm_vars':
assumes "wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "wf⇩t⇩r⇩m⇩s (subst_range (rm_vars X δ))"
using assms by force
lemma wf_trms_subst_compose:
assumes "wf⇩t⇩r⇩m⇩s (subst_range θ)" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s δ))"
using assms subst_img_comp_subset' wf_trm_subst by blast
lemma wf_trm_subst_compose:
fixes δ::"('fun, 'v) subst"
assumes "wf⇩t⇩r⇩m (θ x)" "⋀x. wf⇩t⇩r⇩m (δ x)"
shows "wf⇩t⇩r⇩m ((θ ∘⇩s δ) x)"
using wf_trm_subst[of δ "θ x", OF wf_trm_subst_rangeI[OF assms(2)]] assms(1)
subst_subst_compose[of "Var x" θ δ]
subst_apply_term.simps(1)[of x θ]
subst_apply_term.simps(1)[of x "θ ∘⇩s δ"]
by argo
lemma wf_trms_Var_range:
assumes "subst_range δ ⊆ range Var"
shows "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using assms by fastforce
lemma wf_trms_subst_compose_Var_range:
assumes "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and "subst_range δ ⊆ range Var"
shows "wf⇩t⇩r⇩m⇩s (subst_range (δ ∘⇩s θ))"
and "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s δ))"
using assms wf_trms_subst_compose wf_trms_Var_range by metis+
lemma wf_trm_subst_inv: "wf⇩t⇩r⇩m (t ⋅ δ) ⟹ wf⇩t⇩r⇩m t"
unfolding wf⇩t⇩r⇩m_def by (induct t) auto
lemma wf_trms_subst_inv: "wf⇩t⇩r⇩m⇩s (M ⋅⇩s⇩e⇩t δ) ⟹ wf⇩t⇩r⇩m⇩s M"
using wf_trm_subst_inv by fast
lemma wf_trm_subterms: "wf⇩t⇩r⇩m t ⟹ wf⇩t⇩r⇩m⇩s (subterms t)"
using wf_trm_subterm by blast
lemma wf_trms_subterms: "wf⇩t⇩r⇩m⇩s M ⟹ wf⇩t⇩r⇩m⇩s (subterms⇩s⇩e⇩t M)"
using wf_trm_subterms by blast
lemma wf_trm_arity: "wf⇩t⇩r⇩m (Fun f T) ⟹ length T = arity f"
unfolding wf⇩t⇩r⇩m_def by blast
lemma wf_trm_subterm_arity: "wf⇩t⇩r⇩m t ⟹ Fun f T ⊑ t ⟹ length T = arity f"
unfolding wf⇩t⇩r⇩m_def by blast
lemma unify_list_wf_trm:
assumes "Unification.unify E B = Some U" "∀(s,t) ∈ set E. wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t"
and "∀(v,t) ∈ set B. wf⇩t⇩r⇩m t"
shows "∀(v,t) ∈ set U. wf⇩t⇩r⇩m t"
using assms
proof (induction E B arbitrary: U rule: Unification.unify.induct)
case (1 B U) thus ?case by auto
next
case (2 f T g S E B U)
have wf_fun: "wf⇩t⇩r⇩m (Fun f T)" "wf⇩t⇩r⇩m (Fun g S)" using "2.prems"(2) by auto
from "2.prems"(1) obtain E' where *: "decompose (Fun f T) (Fun g S) = Some E'"
and [simp]: "f = g" "length T = length S" "E' = zip T S"
and **: "Unification.unify (E'@E) B = Some U"
by (auto split: option.splits)
hence "t ⊏ Fun f T" "t' ⊏ Fun g S" when "(t,t') ∈ set E'" for t t'
using that by (metis zip_arg_subterm(1), metis zip_arg_subterm(2))
hence "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m t'" when "(t,t') ∈ set E'" for t t'
using wf_trm_subterm wf_fun ‹f = g› that by blast+
thus ?case using "2.IH"[OF * ** _ "2.prems"(3)] "2.prems"(2) by fastforce
next
case (3 v t E B)
hence *: "∀(w,x) ∈ set ((v, t) # B). wf⇩t⇩r⇩m x"
and **: "∀(s,t) ∈ set E. wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m t"
by auto
show ?case
proof (cases "t = Var v")
case True thus ?thesis using "3.prems" "3.IH"(1) by auto
next
case False
hence "v ∉ fv t" using "3.prems"(1) by auto
hence "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U"
using ‹t ≠ Var v› "3.prems"(1) by auto
moreover have "∀(s, t) ∈ set (subst_list (subst v t) E). wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t"
using wf_trm_subst_singleton[OF _ ‹wf⇩t⇩r⇩m t›] "3.prems"(2)
unfolding subst_list_def subst_def by auto
ultimately show ?thesis using "3.IH"(2)[OF ‹t ≠ Var v› ‹v ∉ fv t› _ _ *] by metis
qed
next
case (4 f T v E B U)
hence *: "∀(w,x) ∈ set ((v, Fun f T) # B). wf⇩t⇩r⇩m x"
and **: "∀(s,t) ∈ set E. wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m (Fun f T)"
by auto
have "v ∉ fv (Fun f T)" using "4.prems"(1) by force
hence "Unification.unify (subst_list (subst v (Fun f T)) E) ((v, Fun f T)#B) = Some U"
using "4.prems"(1) by auto
moreover have "∀(s, t) ∈ set (subst_list (subst v (Fun f T)) E). wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t"
using wf_trm_subst_singleton[OF _ ‹wf⇩t⇩r⇩m (Fun f T)›] "4.prems"(2)
unfolding subst_list_def subst_def by auto
ultimately show ?case using "4.IH"[OF ‹v ∉ fv (Fun f T)› _ _ *] by metis
qed
lemma mgu_wf_trm:
assumes "mgu s t = Some σ" "wf⇩t⇩r⇩m s" "wf⇩t⇩r⇩m t"
shows "wf⇩t⇩r⇩m (σ v)"
proof -
from assms obtain σ' where "subst_of σ' = σ" "∀(v,t) ∈ set σ'. wf⇩t⇩r⇩m t"
using unify_list_wf_trm[of "[(s,t)]" "[]"] by (auto split: option.splits)
thus ?thesis
proof (induction σ' arbitrary: σ v rule: List.rev_induct)
case (snoc x σ' σ v)
define θ where "θ = subst_of σ'"
hence "wf⇩t⇩r⇩m (θ v)" for v using snoc.prems(2) snoc.IH[of θ] by fastforce
moreover obtain w t where x: "x = (w,t)" by (metis surj_pair)
hence σ: "σ = Var(w := t) ∘⇩s θ" using snoc.prems(1) by (simp add: subst_def θ_def)
moreover have "wf⇩t⇩r⇩m t" using snoc.prems(2) x by auto
ultimately show ?case using wf_trm_subst[of _ t] unfolding subst_compose_def by auto
qed (simp add: wf⇩t⇩r⇩m_def)
qed
lemma mgu_wf_trms:
assumes "mgu s t = Some σ" "wf⇩t⇩r⇩m s" "wf⇩t⇩r⇩m t"
shows "wf⇩t⇩r⇩m⇩s (subst_range σ)"
using mgu_wf_trm[OF assms] by simp
subsection ‹Definitions: Intruder Deduction Relations›
text ‹
A standard Dolev-Yao intruder.
›
inductive intruder_deduct::"('fun,'var) terms ⇒ ('fun,'var) term ⇒ bool"
where
Axiom[simp]: "t ∈ M ⟹ intruder_deduct M t"
| Compose[simp]: "⟦length T = arity f; public f; ⋀t. t ∈ set T ⟹ intruder_deduct M t⟧
⟹ intruder_deduct M (Fun f T)"
| Decompose: "⟦intruder_deduct M t; Ana t = (K, T); ⋀k. k ∈ set K ⟹ intruder_deduct M k;
t⇩i ∈ set T⟧
⟹ intruder_deduct M t⇩i"
text ‹
A variant of the intruder relation which limits the intruder to composition only.
›
inductive intruder_synth::"('fun,'var) terms ⇒ ('fun,'var) term ⇒ bool"
where
AxiomC[simp]: "t ∈ M ⟹ intruder_synth M t"
| ComposeC[simp]: "⟦length T = arity f; public f; ⋀t. t ∈ set T ⟹ intruder_synth M t⟧
⟹ intruder_synth M (Fun f T)"
adhoc_overloading INTRUDER_DEDUCT intruder_deduct
adhoc_overloading INTRUDER_SYNTH intruder_synth
lemma intruder_deduct_induct[consumes 1, case_names Axiom Compose Decompose]:
assumes "M ⊢ t" "⋀t. t ∈ M ⟹ P M t"
"⋀T f. ⟦length T = arity f; public f;
⋀t. t ∈ set T ⟹ M ⊢ t;
⋀t. t ∈ set T ⟹ P M t⟧ ⟹ P M (Fun f T)"
"⋀t K T t⇩i. ⟦M ⊢ t; P M t; Ana t = (K, T); ⋀k. k ∈ set K ⟹ M ⊢ k;
⋀k. k ∈ set K ⟹ P M k; t⇩i ∈ set T⟧ ⟹ P M t⇩i"
shows "P M t"
using assms by (induct rule: intruder_deduct.induct) blast+
lemma intruder_synth_induct[consumes 1, case_names AxiomC ComposeC]:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
assumes "M ⊢⇩c t" "⋀t. t ∈ M ⟹ P M t"
"⋀T f. ⟦length T = arity f; public f;
⋀t. t ∈ set T ⟹ M ⊢⇩c t;
⋀t. t ∈ set T ⟹ P M t⟧ ⟹ P M (Fun f T)"
shows "P M t"
using assms by (induct rule: intruder_synth.induct) auto
subsection ‹Definitions: Analyzed Knowledge and Public Ground Well-formed Terms (PGWTs)›
definition analyzed::"('fun,'var) terms ⇒ bool" where
"analyzed M ≡ ∀t. M ⊢ t ⟷ M ⊢⇩c t"
definition analyzed_in where
"analyzed_in t M ≡ ∀K R. (Ana t = (K,R) ∧ (∀k ∈ set K. M ⊢⇩c k)) ⟶ (∀r ∈ set R. M ⊢⇩c r)"
definition decomp_closure::"('fun,'var) terms ⇒ ('fun,'var) terms ⇒ bool" where
"decomp_closure M M' ≡ ∀t. M ⊢ t ∧ (∃t' ∈ M. t ⊑ t') ⟷ t ∈ M'"
inductive public_ground_wf_term::"('fun,'var) term ⇒ bool" where
PGWT[simp]: "⟦public f; arity f = length T;
⋀t. t ∈ set T ⟹ public_ground_wf_term t⟧
⟹ public_ground_wf_term (Fun f T)"
abbreviation "public_ground_wf_terms ≡ {t. public_ground_wf_term t}"
lemma public_const_deduct:
assumes "c ∈ 𝒞⇩p⇩u⇩b"
shows "M ⊢ Fun c []" "M ⊢⇩c Fun c []"
proof -
have "arity c = 0" "public c" using const_arity_eq_zero ‹c ∈ 𝒞⇩p⇩u⇩b› by auto
thus "M ⊢ Fun c []" "M ⊢⇩c Fun c []"
using intruder_synth.ComposeC[OF _ ‹public c›, of "[]"]
intruder_deduct.Compose[OF _ ‹public c›, of "[]"]
by auto
qed
lemma public_const_deduct'[simp]:
assumes "arity c = 0" "public c"
shows "M ⊢ Fun c []" "M ⊢⇩c Fun c []"
using intruder_deduct.Compose[of "[]" c] intruder_synth.ComposeC[of "[]" c] assms by simp_all
lemma private_fun_deduct_in_ik:
assumes t: "M ⊢ t" "Fun f T ∈ subterms t"
and f: "¬public f"
shows "Fun f T ∈ subterms⇩s⇩e⇩t M"
using t
proof (induction t rule: intruder_deduct.induct)
case Decompose thus ?case by (meson Ana_subterm psubsetD term.order_trans)
qed (auto simp add: f in_subterms_Union)
lemma private_fun_deduct_in_ik':
assumes t: "M ⊢ Fun f T"
and f: "¬public f"
and M: "Fun f T ∈ subterms⇩s⇩e⇩t M ⟹ Fun f T ∈ M"
shows "Fun f T ∈ M"
by (rule M[OF private_fun_deduct_in_ik[OF t term.order_refl f]])
lemma pgwt_public: "⟦public_ground_wf_term t; Fun f T ⊑ t⟧ ⟹ public f"
by (induct t rule: public_ground_wf_term.induct) auto
lemma pgwt_ground: "public_ground_wf_term t ⟹ fv t = {}"
by (induct t rule: public_ground_wf_term.induct) auto
lemma pgwt_fun: "public_ground_wf_term t ⟹ ∃f T. t = Fun f T"
using pgwt_ground[of t] by (cases t) auto
lemma pgwt_arity: "⟦public_ground_wf_term t; Fun f T ⊑ t⟧ ⟹ arity f = length T"
by (induct t rule: public_ground_wf_term.induct) auto
lemma pgwt_wellformed: "public_ground_wf_term t ⟹ wf⇩t⇩r⇩m t"
by (induct t rule: public_ground_wf_term.induct) auto
lemma pgwt_deducible: "public_ground_wf_term t ⟹ M ⊢⇩c t"
by (induct t rule: public_ground_wf_term.induct) auto
lemma pgwt_is_empty_synth: "public_ground_wf_term t ⟷ {} ⊢⇩c t"
proof -
{ fix M::"('fun,'var) term set" assume "M ⊢⇩c t" "M = {}" hence "public_ground_wf_term t"
by (induct t rule: intruder_synth.induct) auto
}
thus ?thesis using pgwt_deducible by auto
qed
lemma ideduct_synth_subst_apply:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
assumes "{} ⊢⇩c t" "⋀v. M ⊢⇩c θ v"
shows "M ⊢⇩c t ⋅ θ"
proof -
{ fix M'::"('fun,'var) term set" assume "M' ⊢⇩c t" "M' = {}" hence "M ⊢⇩c t ⋅ θ"
proof (induction t rule: intruder_synth.induct)
case (ComposeC T f M')
hence "length (map (λt. t ⋅ θ) T) = arity f" "⋀x. x ∈ set (map (λt. t ⋅ θ) T) ⟹ M ⊢⇩c x"
by auto
thus ?case using intruder_synth.ComposeC[of "map (λt. t ⋅ θ) T" f M] ‹public f› by fastforce
qed simp
}
thus ?thesis using assms by metis
qed
subsection ‹Lemmata: Monotonicity, deduction private constants, etc.›
context
begin
lemma ideduct_mono:
"⟦M ⊢ t; M ⊆ M'⟧ ⟹ M' ⊢ t"
proof (induction rule: intruder_deduct.induct)
case (Decompose M t K T t⇩i)
have "∀k. k ∈ set K ⟶ M' ⊢ k" using Decompose.IH ‹M ⊆ M'› by simp
moreover have "M' ⊢ t" using Decompose.IH ‹M ⊆ M'› by simp
ultimately show ?case using Decompose.hyps intruder_deduct.Decompose by blast
qed auto
lemma ideduct_synth_mono:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
shows "⟦M ⊢⇩c t; M ⊆ M'⟧ ⟹ M' ⊢⇩c t"
by (induct rule: intruder_synth.induct) auto
lemma ideduct_reduce:
"⟦M ∪ M' ⊢ t; ⋀t'. t' ∈ M' ⟹ M ⊢ t'⟧ ⟹ M ⊢ t"
proof (induction rule: intruder_deduct_induct)
case Decompose thus ?case using intruder_deduct.Decompose by blast
qed auto
lemma ideduct_synth_reduce:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
shows "⟦M ∪ M' ⊢⇩c t; ⋀t'. t' ∈ M' ⟹ M ⊢⇩c t'⟧ ⟹ M ⊢⇩c t"
by (induct rule: intruder_synth_induct) auto
lemma ideduct_mono_eq:
assumes "∀t. M ⊢ t ⟷ M' ⊢ t" shows "M ∪ N ⊢ t ⟷ M' ∪ N ⊢ t"
proof
show "M ∪ N ⊢ t ⟹ M' ∪ N ⊢ t"
proof (induction t rule: intruder_deduct_induct)
case (Axiom t) thus ?case
proof (cases "t ∈ M")
case True
hence "M ⊢ t" using intruder_deduct.Axiom by metis
thus ?thesis using assms ideduct_mono[of M' t "M' ∪ N"] by simp
qed auto
next
case (Compose T f) thus ?case using intruder_deduct.Compose by auto
next
case (Decompose t K T t⇩i) thus ?case using intruder_deduct.Decompose[of "M' ∪ N" t K T] by auto
qed
show "M' ∪ N ⊢ t ⟹ M ∪ N ⊢ t"
proof (induction t rule: intruder_deduct_induct)
case (Axiom t) thus ?case
proof (cases "t ∈ M'")
case True
hence "M' ⊢ t" using intruder_deduct.Axiom by metis
thus ?thesis using assms ideduct_mono[of M t "M ∪ N"] by simp
qed auto
next
case (Compose T f) thus ?case using intruder_deduct.Compose by auto
next
case (Decompose t K T t⇩i) thus ?case using intruder_deduct.Decompose[of "M ∪ N" t K T] by auto
qed
qed
lemma deduct_synth_subterm:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
assumes "M ⊢⇩c t" "s ∈ subterms t" "∀m ∈ M. ∀s ∈ subterms m. M ⊢⇩c s"
shows "M ⊢⇩c s"
using assms by (induct t rule: intruder_synth.induct) auto
lemma deduct_if_synth[intro, dest]: "M ⊢⇩c t ⟹ M ⊢ t"
by (induct rule: intruder_synth.induct) auto
private lemma ideduct_ik_eq: assumes "∀t ∈ M. M' ⊢ t" shows "M' ⊢ t ⟷ M' ∪ M ⊢ t"
by (meson assms ideduct_mono ideduct_reduce sup_ge1)
private lemma synth_if_deduct_empty: "{} ⊢ t ⟹ {} ⊢⇩c t"
proof (induction t rule: intruder_deduct_induct)
case (Decompose t K M m)
then obtain f T where "t = Fun f T" "m ∈ set T"
using Ana_fun_subterm Ana_var by (cases t) fastforce+
with Decompose.IH(1) show ?case by (induction rule: intruder_synth_induct) auto
qed auto
private lemma ideduct_deduct_synth_mono_eq:
assumes "∀t. M ⊢ t ⟷ M' ⊢⇩c t" "M ⊆ M'"
and "∀t. M' ∪ N ⊢ t ⟷ M' ∪ N ∪ D ⊢⇩c t"
shows "M ∪ N ⊢ t ⟷ M' ∪ N ∪ D ⊢⇩c t"
proof -
have "∀m ∈ M'. M ⊢ m" using assms(1) by auto
hence "∀t. M ⊢ t ⟷ M' ⊢ t" by (metis assms(1,2) deduct_if_synth ideduct_reduce sup.absorb2)
hence "∀t. M' ∪ N ⊢ t ⟷ M ∪ N ⊢ t" by (meson ideduct_mono_eq)
thus ?thesis by (meson assms(3))
qed
lemma ideduct_subst: "M ⊢ t ⟹ M ⋅⇩s⇩e⇩t δ ⊢ t ⋅ δ"
proof (induction t rule: intruder_deduct_induct)
case (Compose T f)
hence "length (map (λt. t ⋅ δ) T) = arity f" "⋀t. t ∈ set T ⟹ M ⋅⇩s⇩e⇩t δ ⊢ t ⋅ δ" by auto
thus ?case using intruder_deduct.Compose[OF _ Compose.hyps(2), of "map (λt. t ⋅ δ) T"] by auto
next
case (Decompose t K M' m')
hence "Ana (t ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ, M' ⋅⇩l⇩i⇩s⇩t δ)"
"⋀k. k ∈ set (K ⋅⇩l⇩i⇩s⇩t δ) ⟹ M ⋅⇩s⇩e⇩t δ ⊢ k"
"m' ⋅ δ ∈ set (M' ⋅⇩l⇩i⇩s⇩t δ)"
using Ana_subst[OF Decompose.hyps(2)] by fastforce+
thus ?case using intruder_deduct.Decompose[OF Decompose.IH(1)] by metis
qed simp
lemma ideduct_synth_subst:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term" and δ::"('fun,'var) subst"
shows "M ⊢⇩c t ⟹ M ⋅⇩s⇩e⇩t δ ⊢⇩c t ⋅ δ"
proof (induction t rule: intruder_synth_induct)
case (ComposeC T f)
hence "length (map (λt. t ⋅ δ) T) = arity f" "⋀t. t ∈ set T ⟹ M ⋅⇩s⇩e⇩t δ ⊢⇩c t ⋅ δ" by auto
thus ?case using intruder_synth.ComposeC[OF _ ComposeC.hyps(2), of "map (λt. t ⋅ δ) T"] by auto
qed simp
lemma ideduct_vars:
assumes "M ⊢ t"
shows "fv t ⊆ fv⇩s⇩e⇩t M"
using assms
proof (induction t rule: intruder_deduct_induct)
case (Decompose t K T t⇩i) thus ?case
using Ana_vars(2) fv_subset by blast
qed auto
lemma ideduct_synth_vars:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
assumes "M ⊢⇩c t"
shows "fv t ⊆ fv⇩s⇩e⇩t M"
using assms by (induct t rule: intruder_synth_induct) auto
lemma ideduct_synth_priv_fun_in_ik:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
assumes "M ⊢⇩c t" "f ∈ funs_term t" "¬public f"
shows "f ∈ ⋃(funs_term ` M)"
using assms by (induct t rule: intruder_synth_induct) auto
lemma ideduct_synth_priv_const_in_ik:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
assumes "M ⊢⇩c Fun c []" "¬public c"
shows "Fun c [] ∈ M"
using intruder_synth.cases[OF assms(1)] assms(2) by fast
lemma ideduct_synth_ik_replace:
fixes M::"('fun,'var) terms" and t::"('fun,'var) term"
assumes "∀t ∈ M. N ⊢⇩c t"
and "M ⊢⇩c t"
shows "N ⊢⇩c t"
using assms(2,1) by (induct t rule: intruder_synth.induct) auto
end
subsection ‹Lemmata: Analyzed Intruder Knowledge Closure›
lemma deducts_eq_if_analyzed: "analyzed M ⟹ M ⊢ t ⟷ M ⊢⇩c t"
unfolding analyzed_def by auto
lemma closure_is_superset: "decomp_closure M M' ⟹ M ⊆ M'"
unfolding decomp_closure_def by force
lemma deduct_if_closure_deduct: "⟦M' ⊢ t; decomp_closure M M'⟧ ⟹ M ⊢ t"
proof (induction t rule: intruder_deduct.induct)
case (Decompose M' t K T t⇩i)
thus ?case using intruder_deduct.Decompose[OF _ ‹Ana t = (K,T)› _ ‹t⇩i ∈ set T›] by simp
qed (auto simp add: decomp_closure_def)
lemma deduct_if_closure_synth: "⟦decomp_closure M M'; M' ⊢⇩c t⟧ ⟹ M ⊢ t"
using deduct_if_closure_deduct by blast
lemma decomp_closure_subterms_composable:
assumes "decomp_closure M M'"
and "M' ⊢⇩c t'" "M' ⊢ t" "t ⊑ t'"
shows "M' ⊢⇩c t"
using ‹M' ⊢⇩c t'› assms
proof (induction t' rule: intruder_synth.induct)
case (AxiomC t' M')
have "M ⊢ t" using ‹M' ⊢ t› deduct_if_closure_deduct AxiomC.prems(1) by blast
moreover
{ have "∃s ∈ M. t' ⊑ s" using ‹t' ∈ M'› AxiomC.prems(1) unfolding decomp_closure_def by blast
hence "∃s ∈ M. t ⊑ s" using ‹t ⊑ t'› term.order_trans by auto
}
ultimately have "t ∈ M'" using AxiomC.prems(1) unfolding decomp_closure_def by blast
thus ?case by simp
next
case (ComposeC T f M')
let ?t' = "Fun f T"
{ assume "t = ?t'" have "M' ⊢⇩c t" using ‹M' ⊢⇩c ?t'› ‹t = ?t'› by simp }
moreover
{ assume "t ≠ ?t'"
have "∃x ∈ set T. t ⊑ x" using ‹t ⊑ ?t'› ‹t ≠ ?t'› by simp
hence "M' ⊢⇩c t" using ComposeC.IH ComposeC.prems(1,3) ComposeC.hyps(3) by blast
}
ultimately show ?case using cases_simp[of "t = ?t'" "M' ⊢⇩c t"] by simp
qed
lemma decomp_closure_analyzed:
assumes "decomp_closure M M'"
shows "analyzed M'"
proof -
{ fix t assume "M' ⊢ t" have "M' ⊢⇩c t" using ‹M' ⊢ t› assms
proof (induction t rule: intruder_deduct.induct)
case (Decompose M' t K T t⇩i)
hence "M' ⊢ t⇩i" using Decompose.hyps intruder_deduct.Decompose by blast
moreover have "t⇩i ⊑ t"
using Decompose.hyps(4) Ana_subterm[OF Decompose.hyps(2)] by blast
moreover have "M' ⊢⇩c t" using Decompose.IH(1) Decompose.prems by blast
ultimately show "M' ⊢⇩c t⇩i" using decomp_closure_subterms_composable Decompose.prems by blast
qed auto
}
moreover have "∀t. M ⊢⇩c t ⟶ M ⊢ t" by auto
ultimately show ?thesis by (auto simp add: decomp_closure_def analyzed_def)
qed
lemma analyzed_if_all_analyzed_in:
assumes M: "∀t ∈ M. analyzed_in t M"
shows "analyzed M"
proof (unfold analyzed_def, intro allI iffI)
fix t
assume t: "M ⊢ t"
thus "M ⊢⇩c t"
proof (induction t rule: intruder_deduct_induct)
case (Decompose t K T t⇩i)
{ assume "t ∈ M"
hence ?case
using M Decompose.IH(2) Decompose.hyps(2,4)
unfolding analyzed_in_def by fastforce
} moreover {
fix f S assume "t = Fun f S" "⋀s. s ∈ set S ⟹ M ⊢⇩c s"
hence ?case using Ana_fun_subterm[of f S] Decompose.hyps(2,4) by blast
} ultimately show ?case using intruder_synth.cases[OF Decompose.IH(1), of ?case] by blast
qed simp_all
qed auto
lemma analyzed_is_all_analyzed_in:
"(∀t ∈ M. analyzed_in t M) ⟷ analyzed M"
proof
show "analyzed M ⟹ ∀t ∈ M. analyzed_in t M"
unfolding analyzed_in_def analyzed_def
by (auto intro: intruder_deduct.Decompose[OF intruder_deduct.Axiom])
qed (rule analyzed_if_all_analyzed_in)
lemma ik_has_synth_ik_closure:
fixes M :: "('fun,'var) terms"
shows "∃M'. (∀t. M ⊢ t ⟷ M' ⊢⇩c t) ∧ decomp_closure M M' ∧ (finite M ⟶ finite M')"
proof -
let ?M' = "{t. M ⊢ t ∧ (∃t' ∈ M. t ⊑ t')}"
have M'_closes: "decomp_closure M ?M'" unfolding decomp_closure_def by simp
hence "M ⊆ ?M'" using closure_is_superset by simp
have "∀t. ?M' ⊢⇩c t ⟶ M ⊢ t" using deduct_if_closure_synth[OF M'_closes] by blast
moreover have "∀t. M ⊢ t ⟶ ?M' ⊢ t" using ideduct_mono[OF _ ‹M ⊆ ?M'›] by simp
moreover have "analyzed ?M'" using decomp_closure_analyzed[OF M'_closes] .
ultimately have "∀t. M ⊢ t ⟷ ?M' ⊢⇩c t" unfolding analyzed_def by blast
moreover have "finite M ⟶ finite ?M'" by auto
ultimately show ?thesis using M'_closes by blast
qed
subsection ‹Intruder Variants: Numbered and Composition-Restricted Intruder Deduction Relations›
text ‹
A variant of the intruder relation which restricts composition to only those terms that satisfy
a given predicate Q.
›
inductive intruder_deduct_restricted::
"('fun,'var) terms ⇒ (('fun,'var) term ⇒ bool) ⇒ ('fun,'var) term ⇒ bool"
("⟨_;_⟩ ⊢⇩r _" 50)
where
AxiomR[simp]: "t ∈ M ⟹ ⟨M; Q⟩ ⊢⇩r t"
| ComposeR[simp]: "⟦length T = arity f; public f; ⋀t. t ∈ set T ⟹ ⟨M; Q⟩ ⊢⇩r t; Q (Fun f T)⟧
⟹ ⟨M; Q⟩ ⊢⇩r Fun f T"
| DecomposeR: "⟦⟨M; Q⟩ ⊢⇩r t; Ana t = (K, T); ⋀k. k ∈ set K ⟹ ⟨M; Q⟩ ⊢⇩r k; t⇩i ∈ set T⟧
⟹ ⟨M; Q⟩ ⊢⇩r t⇩i"
text ‹
A variant of the intruder relation equipped with a number representing the heigth of the
derivation tree (i.e., ‹⟨M; k⟩ ⊢⇩n t› iff k is the maximum number of applications of the compose
an decompose rules in any path of the derivation tree for ‹M ⊢ t›).
›
inductive intruder_deduct_num::
"('fun,'var) terms ⇒ nat ⇒ ('fun,'var) term ⇒ bool"
("⟨_; _⟩ ⊢⇩n _" 50)
where
AxiomN[simp]: "t ∈ M ⟹ ⟨M; 0⟩ ⊢⇩n t"
| ComposeN[simp]: "⟦length T = arity f; public f; ⋀t. t ∈ set T ⟹ ⟨M; steps t⟩ ⊢⇩n t⟧
⟹ ⟨M; Suc (Max (insert 0 (steps ` set T)))⟩ ⊢⇩n Fun f T"
| DecomposeN: "⟦⟨M; n⟩ ⊢⇩n t; Ana t = (K, T); ⋀k. k ∈ set K ⟹ ⟨M; steps k⟩ ⊢⇩n k; t⇩i ∈ set T⟧
⟹ ⟨M; Suc (Max (insert n (steps ` set K)))⟩ ⊢⇩n t⇩i"
lemma intruder_deduct_restricted_induct[consumes 1, case_names AxiomR ComposeR DecomposeR]:
assumes "⟨M; Q⟩ ⊢⇩r t" "⋀t. t ∈ M ⟹ P M Q t"
"⋀T f. ⟦length T = arity f; public f;
⋀t. t ∈ set T ⟹ ⟨M; Q⟩ ⊢⇩r t;
⋀t. t ∈ set T ⟹ P M Q t; Q (Fun f T)
⟧ ⟹ P M Q (Fun f T)"
"⋀t K T t⇩i. ⟦⟨M; Q⟩ ⊢⇩r t; P M Q t; Ana t = (K, T); ⋀k. k ∈ set K ⟹ ⟨M; Q⟩ ⊢⇩r k;
⋀k. k ∈ set K ⟹ P M Q k; t⇩i ∈ set T⟧ ⟹ P M Q t⇩i"
shows "P M Q t"
using assms by (induct t rule: intruder_deduct_restricted.induct) blast+
lemma intruder_deduct_num_induct[consumes 1, case_names AxiomN ComposeN DecomposeN]:
assumes "⟨M; n⟩ ⊢⇩n t" "⋀t. t ∈ M ⟹ P M 0 t"
"⋀T f steps.
⟦length T = arity f; public f;
⋀t. t ∈ set T ⟹ ⟨M; steps t⟩ ⊢⇩n t;
⋀t. t ∈ set T ⟹ P M (steps t) t⟧
⟹ P M (Suc (Max (insert 0 (steps ` set T)))) (Fun f T)"
"⋀t K T t⇩i steps n.
⟦⟨M; n⟩ ⊢⇩n t; P M n t; Ana t = (K, T);
⋀k. k ∈ set K ⟹ ⟨M; steps k⟩ ⊢⇩n k;
t⇩i ∈ set T; ⋀k. k ∈ set K ⟹ P M (steps k) k⟧
⟹ P M (Suc (Max (insert n (steps ` set K)))) t⇩i"
shows "P M n t"
using assms by (induct rule: intruder_deduct_num.induct) blast+
lemma ideduct_restricted_mono:
"⟦⟨M; P⟩ ⊢⇩r t; M ⊆ M'⟧ ⟹ ⟨M'; P⟩ ⊢⇩r t"
proof (induction rule: intruder_deduct_restricted_induct)
case (DecomposeR t K T t⇩i)
have "∀k. k ∈ set K ⟶ ⟨M'; P⟩ ⊢⇩r k" using DecomposeR.IH ‹M ⊆ M'› by simp
moreover have "⟨M'; P⟩ ⊢⇩r t" using DecomposeR.IH ‹M ⊆ M'› by simp
ultimately show ?case
using DecomposeR
intruder_deduct_restricted.DecomposeR[OF _ DecomposeR.hyps(2) _ DecomposeR.hyps(4)]
by blast
qed auto
subsection ‹Lemmata: Intruder Deduction Equivalences›
lemma deduct_if_restricted_deduct: "⟨M;P⟩ ⊢⇩r m ⟹ M ⊢ m"
proof (induction m rule: intruder_deduct_restricted_induct)
case (DecomposeR t K T t⇩i) thus ?case using intruder_deduct.Decompose by blast
qed simp_all
lemma restricted_deduct_if_restricted_ik:
assumes "⟨M;P⟩ ⊢⇩r m" "∀m ∈ M. P m"
and P: "∀t t'. P t ⟶ t' ⊑ t ⟶ P t'"
shows "P m"
using assms(1)
proof (induction m rule: intruder_deduct_restricted_induct)
case (DecomposeR t K T t⇩i)
obtain f S where "t = Fun f S" using Ana_var ‹t⇩i ∈ set T› ‹Ana t = (K, T)› by (cases t) auto
thus ?case using DecomposeR assms(2) P Ana_subterm by blast
qed (simp_all add: assms(2))
lemma deduct_restricted_if_synth:
assumes P: "P m" "∀t t'. P t ⟶ t' ⊑ t ⟶ P t'"
and m: "M ⊢⇩c m"
shows "⟨M; P⟩ ⊢⇩r m"
using m P(1)
proof (induction m rule: intruder_synth_induct)
case (ComposeC T f)
hence "⟨M; P⟩ ⊢⇩r t" when t: "t ∈ set T" for t
using t P(2) subtermeqI''[of _ T f]
by fastforce
thus ?case
using intruder_deduct_restricted.ComposeR[OF ComposeC.hyps(1,2)] ComposeC.prems(1)
by metis
qed simp
lemma deduct_zero_in_ik:
assumes "⟨M; 0⟩ ⊢⇩n t" shows "t ∈ M"
proof -
{ fix k assume "⟨M; k⟩ ⊢⇩n t" hence "k > 0 ∨ t ∈ M" by (induct t) auto
} thus ?thesis using assms by auto
qed
lemma deduct_if_deduct_num: "⟨M; k⟩ ⊢⇩n t ⟹ M ⊢ t"
by (induct t rule: intruder_deduct_num.induct)
(metis intruder_deduct.Axiom,
metis intruder_deduct.Compose,
metis intruder_deduct.Decompose)
lemma deduct_num_if_deduct: "M ⊢ t ⟹ ∃k. ⟨M; k⟩ ⊢⇩n t"
proof (induction t rule: intruder_deduct_induct)
case (Compose T f)
then obtain steps where *: "∀t ∈ set T. ⟨M; steps t⟩ ⊢⇩n t" by moura
then obtain n where "∀t ∈ set T. steps t ≤ n"
using finite_nat_set_iff_bounded_le[of "steps ` set T"]
by auto
thus ?case using ComposeN[OF Compose.hyps(1,2), of M steps] * by force
next
case (Decompose t K T t⇩i)
hence "⋀u. u ∈ insert t (set K) ⟹ ∃k. ⟨M; k⟩ ⊢⇩n u" by auto
then obtain steps where *: "⟨M; steps t⟩ ⊢⇩n t" "∀t ∈ set K. ⟨M; steps t⟩ ⊢⇩n t" by moura
then obtain n where "steps t ≤ n" "∀t ∈ set K. steps t ≤ n"
using finite_nat_set_iff_bounded_le[of "steps ` insert t (set K)"]
by auto
thus ?case using DecomposeN[OF _ Decompose.hyps(2) _ Decompose.hyps(4), of M _ steps] * by force
qed (metis AxiomN)
lemma deduct_normalize:
assumes M: "∀m ∈ M. ∀f T. Fun f T ⊑ m ⟶ P f T"
and t: "⟨M; k⟩ ⊢⇩n t" "Fun f T ⊑ t" "¬P f T"
shows "∃l ≤ k. (⟨M; l⟩ ⊢⇩n Fun f T) ∧ (∀t ∈ set T. ∃j < l. ⟨M; j⟩ ⊢⇩n t)"
using t
proof (induction t rule: intruder_deduct_num_induct)
case (AxiomN t) thus ?case using M by auto
next
case (ComposeN T' f' steps) thus ?case
proof (cases "Fun f' T' = Fun f T")
case True
hence "⟨M; Suc (Max (insert 0 (steps ` set T')))⟩ ⊢⇩n Fun f T" "T = T'"
using intruder_deduct_num.ComposeN[OF ComposeN.hyps] by auto
moreover have "⋀t. t ∈ set T ⟹ ⟨M; steps t⟩ ⊢⇩n t"
using True ComposeN.hyps(3) by auto
moreover have "⋀t. t ∈ set T ⟹ steps t < Suc (Max (insert 0 (steps ` set T)))"
using Max_less_iff[of "insert 0 (steps ` set T)" "Suc (Max (insert 0 (steps ` set T)))"]
by auto
ultimately show ?thesis by auto
next
case False
then obtain t' where t': "t' ∈ set T'" "Fun f T ⊑ t'" using ComposeN by auto
hence "∃l ≤ steps t'. (⟨M; l⟩ ⊢⇩n Fun f T) ∧ (∀t ∈ set T. ∃j < l. ⟨M; j⟩ ⊢⇩n t)"
using ComposeN.IH[OF _ _ ComposeN.prems(2)] by auto
moreover have "steps t' < Suc (Max (insert 0 (steps ` set T')))"
using Max_less_iff[of "insert 0 (steps ` set T')" "Suc (Max (insert 0 (steps ` set T')))"]
using t'(1) by auto
ultimately show ?thesis using ComposeN.hyps(3)[OF t'(1)]
by (meson Suc_le_eq le_Suc_eq le_trans)
qed
next
case (DecomposeN t K T' t⇩i steps n)
hence *: "Fun f T ⊑ t"
using term.order_trans[of "Fun f T" t⇩i t] Ana_subterm[of t K T']
by blast
have "∃l ≤ n. (⟨M; l⟩ ⊢⇩n Fun f T) ∧ (∀t' ∈ set T. ∃j < l. ⟨M; j⟩ ⊢⇩n t')"
using DecomposeN.IH(1)[OF * DecomposeN.prems(2)] by auto
moreover have "n < Suc (Max (insert n (steps ` set K)))"
using Max_less_iff[of "insert n (steps ` set K)" "Suc (Max (insert n (steps ` set K)))"]
by auto
ultimately show ?case using DecomposeN.hyps(4) by (meson Suc_le_eq le_Suc_eq le_trans)
qed
lemma deduct_inv:
assumes "⟨M; n⟩ ⊢⇩n t"
shows "t ∈ M ∨
(∃f T. t = Fun f T ∧ public f ∧ length T = arity f ∧ (∀t ∈ set T. ∃l < n. ⟨M; l⟩ ⊢⇩n t)) ∨
(∃m ∈ subterms⇩s⇩e⇩t M.
(∃l < n. ⟨M; l⟩ ⊢⇩n m) ∧ (∀k ∈ set (fst (Ana m)). ∃l < n. ⟨M; l⟩ ⊢⇩n k) ∧
t ∈ set (snd (Ana m)))"
(is "?P t n ∨ ?Q t n ∨ ?R t n")
using assms
proof (induction n arbitrary: t rule: nat_less_induct)
case (1 n t) thus ?case
proof (cases n)
case 0
hence "t ∈ M" using deduct_zero_in_ik "1.prems"(1) by metis
thus ?thesis by auto
next
case (Suc n')
hence "⟨M; Suc n'⟩ ⊢⇩n t"
"∀m < Suc n'. ∀x. (⟨M; m⟩ ⊢⇩n x) ⟶ ?P x m ∨ ?Q x m ∨ ?R x m"
using "1.prems" "1.IH" by blast+
hence "?P t (Suc n') ∨ ?Q t (Suc n') ∨ ?R t (Suc n')"
proof (induction t rule: intruder_deduct_num_induct)
case (AxiomN t) thus ?case by simp
next
case (ComposeN T f steps)
have "⋀t. t ∈ set T ⟹ steps t < Suc (Max (insert 0 (steps ` set T)))"
using Max_less_iff[of "insert 0 (steps ` set T)" "Suc (Max (insert 0 (steps ` set T)))"]
by auto
thus ?case using ComposeN.hyps by metis
next
case (DecomposeN t K T t⇩i steps n)
have 0: "n < Suc (Max (insert n (steps ` set K)))"
"⋀k. k ∈ set K ⟹ steps k < Suc (Max (insert n (steps ` set K)))"
using Max_less_iff[of "insert n (steps ` set K)" "Suc (Max (insert n (steps ` set K)))"]
by auto
have IH1: "?P t j ∨ ?Q t j ∨ ?R t j" when jt: "j < n" "⟨M; j⟩ ⊢⇩n t" for j t
using jt DecomposeN.prems(1) 0(1)
by simp
have IH2: "?P t n ∨ ?Q t n ∨ ?R t n"
using DecomposeN.IH(1) IH1
by simp
have 1: "∀k ∈ set (fst (Ana t)). ∃l < Suc (Max (insert n (steps ` set K))). ⟨M; l⟩ ⊢⇩n k"
using DecomposeN.hyps(1,2,3) 0(2)
by auto
have 2: "t⇩i ∈ set (snd (Ana t))"
using DecomposeN.hyps(2,4)
by fastforce
have 3: "t ∈ subterms⇩s⇩e⇩t M" when "t ∈ set (snd (Ana m))" "m ⊑⇩s⇩e⇩t M" for m
using that(1) Ana_subterm[of m _ "snd (Ana m)"] in_subterms_subset_Union[OF that(2)]
by (metis (no_types, lifting) prod.collapse psubsetD subsetCE subsetD)
have 4: "?R t⇩i (Suc (Max (insert n (steps ` set K))))" when "?R t n"
using that 0(1) 1 2 3 DecomposeN.hyps(1)
by (metis (no_types, lifting))
have 5: "?R t⇩i (Suc (Max (insert n (steps ` set K))))" when "?P t n"
using that 0(1) 1 2 DecomposeN.hyps(1)
by blast
have 6: ?case when *: "?Q t n"
proof -
obtain g S where g:
"t = Fun g S" "public g" "length S = arity g" "∀t ∈ set S. ∃l < n. ⟨M; l⟩ ⊢⇩n t"
using * by moura
then obtain l where l: "l < n" "⟨M; l⟩ ⊢⇩n t⇩i"
using 0(1) DecomposeN.hyps(2,4) Ana_fun_subterm[of g S K T] by blast
have **: "l < Suc (Max (insert n (steps ` set K)))" using l(1) 0(1) by simp
show ?thesis using IH1[OF l] less_trans[OF _ **] by fastforce
qed
show ?case using IH2 4 5 6 by argo
qed
thus ?thesis using Suc by fast
qed
qed
lemma restricted_deduct_if_deduct:
assumes M: "∀m ∈ M. ∀f T. Fun f T ⊑ m ⟶ P (Fun f T)"
and P_subterm: "∀f T t. M ⊢ Fun f T ⟶ P (Fun f T) ⟶ t ∈ set T ⟶ P t"
and P_Ana_key: "∀t K T k. M ⊢ t ⟶ P t ⟶ Ana t = (K, T) ⟶ M ⊢ k ⟶ k ∈ set K ⟶ P k"
and m: "M ⊢ m" "P m"
shows "⟨M; P⟩ ⊢⇩r m"
proof -
{ fix k assume "⟨M; k⟩ ⊢⇩n m"
hence ?thesis using m(2)
proof (induction k arbitrary: m rule: nat_less_induct)
case (1 n m) thus ?case
proof (cases n)
case 0
hence "m ∈ M" using deduct_zero_in_ik "1.prems"(1) by metis
thus ?thesis by auto
next
case (Suc n')
hence "⟨M; Suc n'⟩ ⊢⇩n m"
"∀m < Suc n'. ∀x. (⟨M; m⟩ ⊢⇩n x) ⟶ P x ⟶ ⟨M;P⟩ ⊢⇩r x"
using "1.prems" "1.IH" by blast+
thus ?thesis using "1.prems"(2)
proof (induction m rule: intruder_deduct_num_induct)
case (ComposeN T f steps)
have *: "steps t < Suc (Max (insert 0 (steps ` set T)))" when "t ∈ set T" for t
using Max_less_iff[of "insert 0 (steps ` set T)"] that
by blast
have **: "P t" when "t ∈ set T" for t
using P_subterm ComposeN.prems(2) that
Fun_param_is_subterm[OF that]
intruder_deduct.Compose[OF ComposeN.hyps(1,2)]
deduct_if_deduct_num[OF ComposeN.hyps(3)]
by blast
have "⟨M; P⟩ ⊢⇩r t" when "t ∈ set T" for t
using ComposeN.prems(1) ComposeN.hyps(3)[OF that] *[OF that] **[OF that]
by blast
thus ?case
by (metis intruder_deduct_restricted.ComposeR[OF ComposeN.hyps(1,2)] ComposeN.prems(2))
next
case (DecomposeN t K T t⇩i steps l)
show ?case
proof (cases "P t")
case True
hence "⋀k. k ∈ set K ⟹ P k"
using P_Ana_key DecomposeN.hyps(1,2,3) deduct_if_deduct_num
by blast
moreover have
"⋀k m x. k ∈ set K ⟹ m < steps k ⟹ ⟨M; m⟩ ⊢⇩n x ⟹ P x ⟹ ⟨M;P⟩ ⊢⇩r x"
proof -
fix k m x assume *: "k ∈ set K" "m < steps k" "⟨M; m⟩ ⊢⇩n x" "P x"
have "steps k ∈ insert l (steps ` set K)" using *(1) by simp
hence "m < Suc (Max (insert l (steps ` set K)))"
using less_trans[OF *(2), of "Suc (Max (insert l (steps ` set K)))"]
Max_less_iff[of "insert l (steps ` set K)"
"Suc (Max (insert l (steps ` set K)))"]
by auto
thus "⟨M;P⟩ ⊢⇩r x" using DecomposeN.prems(1) *(3,4) by simp
qed
ultimately have "⋀k. k ∈ set K ⟹ ⟨M; P⟩ ⊢⇩r k"
using DecomposeN.IH(2) by auto
moreover have "⟨M; P⟩ ⊢⇩r t"
using True DecomposeN.prems(1) DecomposeN.hyps(1) le_imp_less_Suc
Max_less_iff[of "insert l (steps ` set K)" "Suc (Max (insert l (steps ` set K)))"]
by blast
ultimately show ?thesis
using intruder_deduct_restricted.DecomposeR[OF _ DecomposeN.hyps(2)
_ DecomposeN.hyps(4)]
by metis
next
case False
obtain g S where gS: "t = Fun g S" using DecomposeN.hyps(2,4) by (cases t) moura+
hence *: "Fun g S ⊑ t" "¬P (Fun g S)" using False by force+
have "∃j<l. ⟨M; j⟩ ⊢⇩n t⇩i"
using gS DecomposeN.hyps(2,4) Ana_fun_subterm[of g S K T]
deduct_normalize[of M "λf T. P (Fun f T)", OF M DecomposeN.hyps(1) *]
by force
hence "∃j<Suc (Max (insert l (steps ` set K))). ⟨M; j⟩ ⊢⇩n t⇩i"
using Max_less_iff[of "insert l (steps ` set K)"
"Suc (Max (insert l (steps ` set K)))"]
less_trans[of _ l "Suc (Max (insert l (steps ` set K)))"]
by blast
thus ?thesis using DecomposeN.prems(1,2) by meson
qed
qed auto
qed
qed
} thus ?thesis using deduct_num_if_deduct m(1) by metis
qed
lemma restricted_deduct_if_deduct':
assumes "∀m ∈ M. P m"
and "∀t t'. P t ⟶ t' ⊑ t ⟶ P t'"
and "∀t K T k. P t ⟶ Ana t = (K, T) ⟶ k ∈ set K ⟶ P k"
and "M ⊢ m" "P m"
shows "⟨M; P⟩ ⊢⇩r m"
using restricted_deduct_if_deduct[of M P m] assms
by blast
lemma private_const_deduct:
assumes c: "¬public c" "M ⊢ (Fun c []::('fun,'var) term)"
shows "Fun c [] ∈ M ∨
(∃m ∈ subterms⇩s⇩e⇩t M. M ⊢ m ∧ (∀k ∈ set (fst (Ana m)). M ⊢ m) ∧
Fun c [] ∈ set (snd (Ana m)))"
proof -
obtain n where "⟨M; n⟩ ⊢⇩n Fun c []"
using c(2) deduct_num_if_deduct by moura
hence "Fun c [] ∈ M ∨
(∃m ∈ subterms⇩s⇩e⇩t M.
(∃l < n. ⟨M; l⟩ ⊢⇩n m) ∧
(∀k ∈ set (fst (Ana m)). ∃l < n. ⟨M; l⟩ ⊢⇩n k) ∧ Fun c [] ∈ set (snd (Ana m)))"
using deduct_inv[of M n "Fun c []"] c(1) by fast
thus ?thesis using deduct_if_deduct_num[of M] by blast
qed
lemma private_fun_deduct_in_ik'':
assumes t: "M ⊢ Fun f T" "Fun c [] ∈ set T" "∀m ∈ subterms⇩s⇩e⇩t M. Fun f T ∉ set (snd (Ana m))"
and c: "¬public c" "Fun c [] ∉ M" "∀m ∈ subterms⇩s⇩e⇩t M. Fun c [] ∉ set (snd (Ana m))"
shows "Fun f T ∈ M"
proof -
have *: "∄n. ⟨M; n⟩ ⊢⇩n Fun c []"
using private_const_deduct[OF c(1)] c(2,3) deduct_if_deduct_num
by blast
obtain n where n: "⟨M; n⟩ ⊢⇩n Fun f T"
using t(1) deduct_num_if_deduct
by blast
show ?thesis
using deduct_inv[OF n] t(2,3) *
by blast
qed
end
subsection ‹Executable Definitions for Code Generation›
fun intruder_synth' where
"intruder_synth' pu ar M (Var x) = (Var x ∈ M)"
| "intruder_synth' pu ar M (Fun f T) = (
Fun f T ∈ M ∨ (pu f ∧ length T = ar f ∧ list_all (intruder_synth' pu ar M) T))"
definition "wf⇩t⇩r⇩m' ar t ≡ (∀s ∈ subterms t. is_Fun s ⟶ ar (the_Fun s) = length (args s))"
definition "wf⇩t⇩r⇩m⇩s' ar M ≡ (∀t ∈ M. wf⇩t⇩r⇩m' ar t)"
definition "analyzed_in' An pu ar t M ≡ (case An t of
(K,T) ⇒ (∀k ∈ set K. intruder_synth' pu ar M k) ⟶ (∀s ∈ set T. intruder_synth' pu ar M s))"
lemma (in intruder_model) intruder_synth'_induct[consumes 1, case_names Var Fun]:
assumes "intruder_synth' public arity M t"
"⋀x. intruder_synth' public arity M (Var x) ⟹ P (Var x)"
"⋀f T. (⋀z. z ∈ set T ⟹ intruder_synth' public arity M z ⟹ P z) ⟹
intruder_synth' public arity M (Fun f T) ⟹ P (Fun f T) "
shows "P t"
using assms by (induct public arity M t rule: intruder_synth'.induct) auto
lemma (in intruder_model) wf⇩t⇩r⇩m_code[code_unfold]:
"wf⇩t⇩r⇩m t = wf⇩t⇩r⇩m' arity t"
unfolding wf⇩t⇩r⇩m_def wf⇩t⇩r⇩m'_def
by auto
lemma (in intruder_model) wf⇩t⇩r⇩m⇩s_code[code_unfold]:
"wf⇩t⇩r⇩m⇩s M = wf⇩t⇩r⇩m⇩s' arity M"
using wf⇩t⇩r⇩m_code
unfolding wf⇩t⇩r⇩m⇩s'_def
by auto
lemma (in intruder_model) intruder_synth_code[code_unfold]:
"intruder_synth M t = intruder_synth' public arity M t"
(is "?A ⟷ ?B")
proof
show "?A ⟹ ?B"
proof (induction t rule: intruder_synth_induct)
case (AxiomC t) thus ?case by (cases t) auto
qed (fastforce simp add: list_all_iff)
show "?B ⟹ ?A"
proof (induction t rule: intruder_synth'_induct)
case (Fun f T) thus ?case
proof (cases "Fun f T ∈ M")
case False
hence "public f" "length T = arity f" "list_all (intruder_synth' public arity M) T"
using Fun.hyps by fastforce+
thus ?thesis
using Fun.IH intruder_synth.ComposeC[of T f M] Ball_set[of T]
by blast
qed simp
qed simp
qed
lemma (in intruder_model) analyzed_in_code[code_unfold]:
"analyzed_in t M = analyzed_in' Ana public arity t M"
using intruder_synth_code[of M]
unfolding analyzed_in_def analyzed_in'_def
by fastforce
end
Theory Strands_and_Constraints
section ‹Strands and Symbolic Intruder Constraints›
theory Strands_and_Constraints
imports Messages More_Unification Intruder_Deduction
begin
subsection ‹Constraints, Strands and Related Definitions›
datatype poscheckvariant = Assign ("assign") | Check ("check")
text ‹
A strand (or constraint) step is either a message transmission (either a message being sent ‹Send›
or being received ‹Receive›) or a check on messages (a positive check ‹Equality›---which can be
either an "assignment" or just a check---or a negative check ‹Inequality›)
›
datatype (funs⇩s⇩t⇩p: 'a, vars⇩s⇩t⇩p: 'b) strand_step =
Send "('a,'b) term" ("send⟨_⟩⇩s⇩t" 80)
| Receive "('a,'b) term" ("receive⟨_⟩⇩s⇩t" 80)
| Equality poscheckvariant "('a,'b) term" "('a,'b) term" ("⟨_: _ ≐ _⟩⇩s⇩t" [80,80])
| Inequality (bvars⇩s⇩t⇩p: "'b list") "(('a,'b) term × ('a,'b) term) list" ("∀_⟨∨≠: _⟩⇩s⇩t" [80,80])
where
"bvars⇩s⇩t⇩p (Send _) = []"
| "bvars⇩s⇩t⇩p (Receive _) = []"
| "bvars⇩s⇩t⇩p (Equality _ _ _) = []"
text ‹
A strand is a finite sequence of strand steps (constraints and strands share the same datatype)
›
type_synonym ('a,'b) strand = "('a,'b) strand_step list"
type_synonym ('a,'b) strands = "('a,'b) strand set"
abbreviation "trms⇩p⇩a⇩i⇩r⇩s F ≡ ⋃(t,t') ∈ set F. {t,t'}"
fun trms⇩s⇩t⇩p::"('a,'b) strand_step ⇒ ('a,'b) terms" where
"trms⇩s⇩t⇩p (Send t) = {t}"
| "trms⇩s⇩t⇩p (Receive t) = {t}"
| "trms⇩s⇩t⇩p (Equality _ t t') = {t,t'}"
| "trms⇩s⇩t⇩p (Inequality _ F) = trms⇩p⇩a⇩i⇩r⇩s F"
lemma vars⇩s⇩t⇩p_unfold[simp]: "vars⇩s⇩t⇩p x = fv⇩s⇩e⇩t (trms⇩s⇩t⇩p x) ∪ set (bvars⇩s⇩t⇩p x)"
by (cases x) auto
text ‹The set of terms occurring in a strand›
definition trms⇩s⇩t where "trms⇩s⇩t S ≡ ⋃(trms⇩s⇩t⇩p ` set S)"
fun trms_list⇩s⇩t⇩p::"('a,'b) strand_step ⇒ ('a,'b) term list" where
"trms_list⇩s⇩t⇩p (Send t) = [t]"
| "trms_list⇩s⇩t⇩p (Receive t) = [t]"
| "trms_list⇩s⇩t⇩p (Equality _ t t') = [t,t']"
| "trms_list⇩s⇩t⇩p (Inequality _ F) = concat (map (λ(t,t'). [t,t']) F)"
text ‹The set of terms occurring in a strand (list variant)›
definition trms_list⇩s⇩t where "trms_list⇩s⇩t S ≡ remdups (concat (map trms_list⇩s⇩t⇩p S))"
text ‹The set of variables occurring in a sent message›
definition fv⇩s⇩n⇩d::"('a,'b) strand_step ⇒ 'b set" where
"fv⇩s⇩n⇩d x ≡ case x of Send t ⇒ fv t | _ ⇒ {}"
text ‹The set of variables occurring in a received message›
definition fv⇩r⇩c⇩v::"('a,'b) strand_step ⇒ 'b set" where
"fv⇩r⇩c⇩v x ≡ case x of Receive t ⇒ fv t | _ ⇒ {}"
text ‹The set of variables occurring in an equality constraint›
definition fv⇩e⇩q::"poscheckvariant ⇒ ('a,'b) strand_step ⇒ 'b set" where
"fv⇩e⇩q ac x ≡ case x of Equality ac' s t ⇒ if ac = ac' then fv s ∪ fv t else {} | _ ⇒ {}"
text ‹The set of variables occurring at the left-hand side of an equality constraint›
definition fv_l⇩e⇩q::"poscheckvariant ⇒ ('a,'b) strand_step ⇒ 'b set" where
"fv_l⇩e⇩q ac x ≡ case x of Equality ac' s t ⇒ if ac = ac' then fv s else {} | _ ⇒ {}"
text ‹The set of variables occurring at the right-hand side of an equality constraint›
definition fv_r⇩e⇩q::"poscheckvariant ⇒ ('a,'b) strand_step ⇒ 'b set" where
"fv_r⇩e⇩q ac x ≡ case x of Equality ac' s t ⇒ if ac = ac' then fv t else {} | _ ⇒ {}"
text ‹The free variables of inequality constraints›
definition fv⇩i⇩n⇩e⇩q::"('a,'b) strand_step ⇒ 'b set" where
"fv⇩i⇩n⇩e⇩q x ≡ case x of Inequality X F ⇒ fv⇩p⇩a⇩i⇩r⇩s F - set X | _ ⇒ {}"
fun fv⇩s⇩t⇩p::"('a,'b) strand_step ⇒ 'b set" where
"fv⇩s⇩t⇩p (Send t) = fv t"
| "fv⇩s⇩t⇩p (Receive t) = fv t"
| "fv⇩s⇩t⇩p (Equality _ t t') = fv t ∪ fv t'"
| "fv⇩s⇩t⇩p (Inequality X F) = (⋃(t,t') ∈ set F. fv t ∪ fv t') - set X"
text ‹The set of free variables of a strand›
definition fv⇩s⇩t::"('a,'b) strand ⇒ 'b set" where
"fv⇩s⇩t S ≡ ⋃(set (map fv⇩s⇩t⇩p S))"
text ‹The set of bound variables of a strand›
definition bvars⇩s⇩t::"('a,'b) strand ⇒ 'b set" where
"bvars⇩s⇩t S ≡ ⋃(set (map (set ∘ bvars⇩s⇩t⇩p) S))"
text ‹The set of all variables occurring in a strand›
definition vars⇩s⇩t::"('a,'b) strand ⇒ 'b set" where
"vars⇩s⇩t S ≡ ⋃(set (map vars⇩s⇩t⇩p S))"
abbreviation wfrestrictedvars⇩s⇩t⇩p::"('a,'b) strand_step ⇒ 'b set" where
"wfrestrictedvars⇩s⇩t⇩p x ≡
case x of Inequality _ _ ⇒ {} | Equality Check _ _ ⇒ {} | _ ⇒ vars⇩s⇩t⇩p x"
text ‹The variables of a strand whose occurrences might be restricted by well-formedness constraints›
definition wfrestrictedvars⇩s⇩t::"('a,'b) strand ⇒ 'b set" where
"wfrestrictedvars⇩s⇩t S ≡ ⋃(set (map wfrestrictedvars⇩s⇩t⇩p S))"
abbreviation wfvarsoccs⇩s⇩t⇩p where
"wfvarsoccs⇩s⇩t⇩p x ≡ case x of Send t ⇒ fv t | Equality Assign s t ⇒ fv s | _ ⇒ {}"
text ‹The variables of a strand that occur in sent messages or as variables in assignments›
definition wfvarsoccs⇩s⇩t where
"wfvarsoccs⇩s⇩t S ≡ ⋃(set (map wfvarsoccs⇩s⇩t⇩p S))"
text ‹The variables occurring at the right-hand side of assignment steps›
fun assignment_rhs⇩s⇩t where
"assignment_rhs⇩s⇩t [] = {}"
| "assignment_rhs⇩s⇩t (Equality Assign t t'#S) = insert t' (assignment_rhs⇩s⇩t S)"
| "assignment_rhs⇩s⇩t (x#S) = assignment_rhs⇩s⇩t S"
text ‹The set function symbols occurring in a strand›
definition funs⇩s⇩t::"('a,'b) strand ⇒ 'a set" where
"funs⇩s⇩t S ≡ ⋃(set (map funs⇩s⇩t⇩p S))"
fun subst_apply_strand_step::"('a,'b) strand_step ⇒ ('a,'b) subst ⇒ ('a,'b) strand_step"
(infix "⋅⇩s⇩t⇩p" 51) where
"Send t ⋅⇩s⇩t⇩p θ = Send (t ⋅ θ)"
| "Receive t ⋅⇩s⇩t⇩p θ = Receive (t ⋅ θ)"
| "Equality a t t' ⋅⇩s⇩t⇩p θ = Equality a (t ⋅ θ) (t' ⋅ θ)"
| "Inequality X F ⋅⇩s⇩t⇩p θ = Inequality X (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)"
text ‹Substitution application for strands›
definition subst_apply_strand::"('a,'b) strand ⇒ ('a,'b) subst ⇒ ('a,'b) strand"
(infix "⋅⇩s⇩t" 51) where
"S ⋅⇩s⇩t θ ≡ map (λx. x ⋅⇩s⇩t⇩p θ) S"
text ‹The semantics of inequality constraints›
definition
"ineq_model (ℐ::('a,'b) subst) X F ≡
(∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶
list_ex (λf. fst f ⋅ (δ ∘⇩s ℐ) ≠ snd f ⋅ (δ ∘⇩s ℐ)) F)"
fun simple⇩s⇩t⇩p where
"simple⇩s⇩t⇩p (Receive t) = True"
| "simple⇩s⇩t⇩p (Send (Var v)) = True"
| "simple⇩s⇩t⇩p (Inequality X F) = (∃ℐ. ineq_model ℐ X F)"
| "simple⇩s⇩t⇩p _ = False"
text ‹Simple constraints›
definition simple where "simple S ≡ list_all simple⇩s⇩t⇩p S"
text ‹The intruder knowledge of a constraint›
fun ik⇩s⇩t::"('a,'b) strand ⇒ ('a,'b) terms" where
"ik⇩s⇩t [] = {}"
| "ik⇩s⇩t (Receive t#S) = insert t (ik⇩s⇩t S)"
| "ik⇩s⇩t (_#S) = ik⇩s⇩t S"
text ‹Strand well-formedness›
fun wf⇩s⇩t::"'b set ⇒ ('a,'b) strand ⇒ bool" where
"wf⇩s⇩t V [] = True"
| "wf⇩s⇩t V (Receive t#S) = (fv t ⊆ V ∧ wf⇩s⇩t V S)"
| "wf⇩s⇩t V (Send t#S) = wf⇩s⇩t (V ∪ fv t) S"
| "wf⇩s⇩t V (Equality Assign s t#S) = (fv t ⊆ V ∧ wf⇩s⇩t (V ∪ fv s) S)"
| "wf⇩s⇩t V (Equality Check s t#S) = wf⇩s⇩t V S"
| "wf⇩s⇩t V (Inequality _ _#S) = wf⇩s⇩t V S"
text ‹Well-formedness of constraint states›
definition wf⇩c⇩o⇩n⇩s⇩t⇩r::"('a,'b) strand ⇒ ('a,'b) subst ⇒ bool" where
"wf⇩c⇩o⇩n⇩s⇩t⇩r S θ ≡ (wf⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩s⇩t {} S ∧ subst_domain θ ∩ vars⇩s⇩t S = {} ∧
range_vars θ ∩ bvars⇩s⇩t S = {} ∧ fv⇩s⇩t S ∩ bvars⇩s⇩t S = {})"
declare trms⇩s⇩t_def[simp]
declare fv⇩s⇩n⇩d_def[simp]
declare fv⇩r⇩c⇩v_def[simp]
declare fv⇩e⇩q_def[simp]
declare fv_l⇩e⇩q_def[simp]
declare fv_r⇩e⇩q_def[simp]
declare fv⇩i⇩n⇩e⇩q_def[simp]
declare fv⇩s⇩t_def[simp]
declare vars⇩s⇩t_def[simp]
declare bvars⇩s⇩t_def[simp]
declare wfrestrictedvars⇩s⇩t_def[simp]
declare wfvarsoccs⇩s⇩t_def[simp]
lemmas wf⇩s⇩t_induct = wf⇩s⇩t.induct[case_names Nil ConsRcv ConsSnd ConsEq ConsEq2 ConsIneq]
lemmas ik⇩s⇩t_induct = ik⇩s⇩t.induct[case_names Nil ConsRcv ConsSnd ConsEq ConsIneq]
lemmas assignment_rhs⇩s⇩t_induct = assignment_rhs⇩s⇩t.induct[case_names Nil ConsEq2 ConsSnd ConsRcv ConsEq ConsIneq]
subsubsection ‹Lexicographical measure on strands›
definition size⇩s⇩t::"('a,'b) strand ⇒ nat" where
"size⇩s⇩t S ≡ size_list (λx. Max (insert 0 (size ` trms⇩s⇩t⇩p x))) S"
definition measure⇩s⇩t::"((('a, 'b) strand × ('a,'b) subst) × ('a, 'b) strand × ('a,'b) subst) set"
where
"measure⇩s⇩t ≡ measures [λ(S,θ). card (fv⇩s⇩t S), λ(S,θ). size⇩s⇩t S]"
lemma measure⇩s⇩t_alt_def:
"((s,x),(t,y)) ∈ measure⇩s⇩t =
(card (fv⇩s⇩t s) < card (fv⇩s⇩t t) ∨ (card (fv⇩s⇩t s) = card (fv⇩s⇩t t) ∧ size⇩s⇩t s < size⇩s⇩t t))"
by (simp add: measure⇩s⇩t_def size⇩s⇩t_def)
lemma measure⇩s⇩t_trans: "trans measure⇩s⇩t"
by (simp add: trans_def measure⇩s⇩t_def size⇩s⇩t_def)
subsubsection ‹Some lemmata›
lemma trms_list⇩s⇩t_is_trms⇩s⇩t: "trms⇩s⇩t S = set (trms_list⇩s⇩t S)"
unfolding trms⇩s⇩t_def trms_list⇩s⇩t_def
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
lemma subst_apply_strand_step_def:
"s ⋅⇩s⇩t⇩p θ = (case s of
Send t ⇒ Send (t ⋅ θ)
| Receive t ⇒ Receive (t ⋅ θ)
| Equality a t t' ⇒ Equality a (t ⋅ θ) (t' ⋅ θ)
| Inequality X F ⇒ Inequality X (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ))"
by (cases s) simp_all
lemma subst_apply_strand_nil[simp]: "[] ⋅⇩s⇩t δ = []"
unfolding subst_apply_strand_def by simp
lemma finite_funs⇩s⇩t⇩p[simp]: "finite (funs⇩s⇩t⇩p x)" by (cases x) auto
lemma finite_funs⇩s⇩t[simp]: "finite (funs⇩s⇩t S)" unfolding funs⇩s⇩t_def by simp
lemma finite_trms⇩p⇩a⇩i⇩r⇩s[simp]: "finite (trms⇩p⇩a⇩i⇩r⇩s x)" by (induct x) auto
lemma finite_trms⇩s⇩t⇩p[simp]: "finite (trms⇩s⇩t⇩p x)" by (cases x) auto
lemma finite_vars⇩s⇩t⇩p[simp]: "finite (vars⇩s⇩t⇩p x)" by auto
lemma finite_bvars⇩s⇩t⇩p[simp]: "finite (set (bvars⇩s⇩t⇩p x))" by rule
lemma finite_fv⇩s⇩n⇩d[simp]: "finite (fv⇩s⇩n⇩d x)" by (cases x) auto
lemma finite_fv⇩r⇩c⇩v[simp]: "finite (fv⇩r⇩c⇩v x)" by (cases x) auto
lemma finite_fv⇩s⇩t⇩p[simp]: "finite (fv⇩s⇩t⇩p x)" by (cases x) auto
lemma finite_vars⇩s⇩t[simp]: "finite (vars⇩s⇩t S)" by simp
lemma finite_bvars⇩s⇩t[simp]: "finite (bvars⇩s⇩t S)" by simp
lemma finite_fv⇩s⇩t[simp]: "finite (fv⇩s⇩t S)" by simp
lemma finite_wfrestrictedvars⇩s⇩t⇩p[simp]: "finite (wfrestrictedvars⇩s⇩t⇩p x)"
by (cases x) (auto split: poscheckvariant.splits)
lemma finite_wfrestrictedvars⇩s⇩t[simp]: "finite (wfrestrictedvars⇩s⇩t S)"
using finite_wfrestrictedvars⇩s⇩t⇩p by auto
lemma finite_wfvarsoccs⇩s⇩t⇩p[simp]: "finite (wfvarsoccs⇩s⇩t⇩p x)"
by (cases x) (auto split: poscheckvariant.splits)
lemma finite_wfvarsoccs⇩s⇩t[simp]: "finite (wfvarsoccs⇩s⇩t S)"
using finite_wfvarsoccs⇩s⇩t⇩p by auto
lemma finite_ik⇩s⇩t[simp]: "finite (ik⇩s⇩t S)"
by (induct S rule: ik⇩s⇩t.induct) simp_all
lemma finite_assignment_rhs⇩s⇩t[simp]: "finite (assignment_rhs⇩s⇩t S)"
by (induct S rule: assignment_rhs⇩s⇩t.induct) simp_all
lemma ik⇩s⇩t_is_rcv_set: "ik⇩s⇩t A = {t. Receive t ∈ set A}"
by (induct A rule: ik⇩s⇩t.induct) auto
lemma ik⇩s⇩tD[dest]: "t ∈ ik⇩s⇩t S ⟹ Receive t ∈ set S"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma ik⇩s⇩tD'[dest]: "t ∈ ik⇩s⇩t S ⟹ t ∈ trms⇩s⇩t S"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma ik⇩s⇩tD''[dest]: "t ∈ subterms⇩s⇩e⇩t (ik⇩s⇩t S) ⟹ t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩t S)"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma ik⇩s⇩t_subterm_exD:
assumes "t ∈ ik⇩s⇩t S"
shows "∃x ∈ set S. t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩t⇩p x)"
using assms ik⇩s⇩tD by force
lemma assignment_rhs⇩s⇩tD[dest]: "t ∈ assignment_rhs⇩s⇩t S ⟹ ∃t'. Equality Assign t' t ∈ set S"
by (induct S rule: assignment_rhs⇩s⇩t.induct) auto
lemma assignment_rhs⇩s⇩tD'[dest]: "t ∈ subterms⇩s⇩e⇩t (assignment_rhs⇩s⇩t S) ⟹ t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩t S)"
by (induct S rule: assignment_rhs⇩s⇩t.induct) auto
lemma bvars⇩s⇩t_split: "bvars⇩s⇩t (S@S') = bvars⇩s⇩t S ∪ bvars⇩s⇩t S'"
unfolding bvars⇩s⇩t_def by auto
lemma bvars⇩s⇩t_singleton: "bvars⇩s⇩t [x] = set (bvars⇩s⇩t⇩p x)"
unfolding bvars⇩s⇩t_def by auto
lemma strand_fv_bvars_disjointD:
assumes "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}" "Inequality X F ∈ set S"
shows "set X ⊆ bvars⇩s⇩t S" "fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ fv⇩s⇩t S"
using assms by (induct S) fastforce+
lemma strand_fv_bvars_disjoint_unfold:
assumes "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}" "Inequality X F ∈ set S" "Inequality Y G ∈ set S"
shows "set Y ∩ (fv⇩p⇩a⇩i⇩r⇩s F - set X) = {}"
proof -
have "set X ⊆ bvars⇩s⇩t S" "set Y ⊆ bvars⇩s⇩t S"
"fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ fv⇩s⇩t S" "fv⇩p⇩a⇩i⇩r⇩s G - set Y ⊆ fv⇩s⇩t S"
using strand_fv_bvars_disjointD[OF assms(1)] assms(2,3) by auto
thus ?thesis using assms(1) by fastforce
qed
lemma strand_subst_hom[iff]:
"(S@S') ⋅⇩s⇩t θ = (S ⋅⇩s⇩t θ)@(S' ⋅⇩s⇩t θ)" "(x#S) ⋅⇩s⇩t θ = (x ⋅⇩s⇩t⇩p θ)#(S ⋅⇩s⇩t θ)"
unfolding subst_apply_strand_def by auto
lemma strand_subst_comp: "range_vars δ ∩ bvars⇩s⇩t S = {} ⟹ S ⋅⇩s⇩t δ ∘⇩s θ = ((S ⋅⇩s⇩t δ) ⋅⇩s⇩t θ)"
proof (induction S)
case (Cons x S)
have *: "range_vars δ ∩ bvars⇩s⇩t S = {}" "range_vars δ ∩ (set (bvars⇩s⇩t⇩p x)) = {}"
using Cons bvars⇩s⇩t_split[of "[x]" S] append_Cons inf_sup_absorb
by (metis (no_types, lifting) Int_iff Un_commute disjoint_iff_not_equal self_append_conv2,
metis append_self_conv2 bvars⇩s⇩t_singleton inf_bot_right inf_left_commute)
hence IH: "S ⋅⇩s⇩t δ ∘⇩s θ = (S ⋅⇩s⇩t δ) ⋅⇩s⇩t θ" using Cons.IH by auto
have "(x#S ⋅⇩s⇩t δ ∘⇩s θ) = (x ⋅⇩s⇩t⇩p δ ∘⇩s θ)#(S ⋅⇩s⇩t δ ∘⇩s θ)" by (metis strand_subst_hom(2))
hence "... = (x ⋅⇩s⇩t⇩p δ ∘⇩s θ)#((S ⋅⇩s⇩t δ) ⋅⇩s⇩t θ)" by (metis IH)
hence "... = ((x ⋅⇩s⇩t⇩p δ) ⋅⇩s⇩t⇩p θ)#((S ⋅⇩s⇩t δ) ⋅⇩s⇩t θ)" using rm_vars_comp[OF *(2)]
proof (induction x)
case (Inequality X F) thus ?case
by (induct F) (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def)
qed (simp_all add: subst_apply_strand_step_def)
thus ?case using IH by auto
qed (simp add: subst_apply_strand_def)
lemma strand_substI[intro]:
"subst_domain θ ∩ fv⇩s⇩t S = {} ⟹ S ⋅⇩s⇩t θ = S"
"subst_domain θ ∩ vars⇩s⇩t S = {} ⟹ S ⋅⇩s⇩t θ = S"
proof -
show "subst_domain θ ∩ vars⇩s⇩t S = {} ⟹ S ⋅⇩s⇩t θ = S"
proof (induction S)
case (Cons x S)
hence "S ⋅⇩s⇩t θ = S" by auto
moreover have "vars⇩s⇩t⇩p x ∩ subst_domain θ = {}" using Cons.prems by auto
hence "x ⋅⇩s⇩t⇩p θ = x"
proof (induction x)
case (Inequality X F) thus ?case
by (induct F) (force simp add: subst_apply_pairs_def)+
qed auto
ultimately show ?case by simp
qed (simp add: subst_apply_strand_def)
show "subst_domain θ ∩ fv⇩s⇩t S = {} ⟹ S ⋅⇩s⇩t θ = S"
proof (induction S)
case (Cons x S)
hence "S ⋅⇩s⇩t θ = S" by auto
moreover have "fv⇩s⇩t⇩p x ∩ subst_domain θ = {}"
using Cons.prems by auto
hence "x ⋅⇩s⇩t⇩p θ = x"
proof (induction x)
case (Inequality X F) thus ?case
by (induct F) (force simp add: subst_apply_pairs_def)+
qed auto
ultimately show ?case by simp
qed (simp add: subst_apply_strand_def)
qed
lemma strand_substI':
"fv⇩s⇩t S = {} ⟹ S ⋅⇩s⇩t θ = S"
"vars⇩s⇩t S = {} ⟹ S ⋅⇩s⇩t θ = S"
by (metis inf_bot_right strand_substI(1),
metis inf_bot_right strand_substI(2))
lemma strand_subst_set: "(set (S ⋅⇩s⇩t θ)) = ((λx. x ⋅⇩s⇩t⇩p θ) ` (set S))"
by (auto simp add: subst_apply_strand_def)
lemma strand_map_inv_set_snd_rcv_subst:
assumes "finite (M::('a,'b) terms)"
shows "set ((map Send (inv set M)) ⋅⇩s⇩t θ) = Send ` (M ⋅⇩s⇩e⇩t θ)" (is ?A)
"set ((map Receive (inv set M)) ⋅⇩s⇩t θ) = Receive ` (M ⋅⇩s⇩e⇩t θ)" (is ?B)
proof -
{ fix f::"('a,'b) term ⇒ ('a,'b) strand_step" assume f: "f = Send ∨ f = Receive"
from assms have "set ((map f (inv set M)) ⋅⇩s⇩t θ) = f ` (M ⋅⇩s⇩e⇩t θ)"
proof (induction rule: finite_induct)
case empty thus ?case unfolding inv_def by auto
next
case (insert m M)
have "set (map f (inv set (insert m M)) ⋅⇩s⇩t θ) =
insert (f m ⋅⇩s⇩t⇩p θ) (set (map f (inv set M) ⋅⇩s⇩t θ))"
by (simp add: insert.hyps(1) inv_set_fset subst_apply_strand_def)
thus ?case using f insert.IH by auto
qed
}
thus "?A" "?B" by auto
qed
lemma strand_ground_subst_vars_subset:
assumes "ground (subst_range θ)" shows "vars⇩s⇩t (S ⋅⇩s⇩t θ) ⊆ vars⇩s⇩t S"
proof (induction S)
case (Cons x S)
have "vars⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p θ) ⊆ vars⇩s⇩t⇩p x" using ground_subst_fv_subset[OF assms]
proof (cases x)
case (Inequality X F)
let ?θ = "rm_vars (set X) θ"
have "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) ⊆ fv⇩p⇩a⇩i⇩r⇩s F"
proof (induction F)
case (Cons f F)
obtain t t' where f: "f = (t,t')" by (metis surj_pair)
hence "fv⇩p⇩a⇩i⇩r⇩s (f#F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) = fv (t ⋅ ?θ) ∪ fv (t' ⋅ ?θ) ∪ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ)"
"fv⇩p⇩a⇩i⇩r⇩s (f#F) = fv t ∪ fv t' ∪ fv⇩p⇩a⇩i⇩r⇩s F"
by (auto simp add: subst_apply_pairs_def)
thus ?case
using ground_subst_fv_subset[OF ground_subset[OF rm_vars_img_subset assms, of "set X"]]
Cons.IH
by (metis (no_types, lifting) Un_mono)
qed (simp add: subst_apply_pairs_def)
moreover have
"vars⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p θ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∪ set X"
"vars⇩s⇩t⇩p x = fv⇩p⇩a⇩i⇩r⇩s F ∪ set X"
using Inequality
by (auto simp add: subst_apply_pairs_def)
ultimately show ?thesis by auto
qed auto
thus ?case using Cons.IH by auto
qed (simp add: subst_apply_strand_def)
lemma ik_union_subset: "⋃(P ` ik⇩s⇩t S) ⊆ (⋃x ∈ (set S). ⋃(P ` trms⇩s⇩t⇩p x))"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma ik_snd_empty[simp]: "ik⇩s⇩t (map Send X) = {}"
by (induct "map Send X" arbitrary: X rule: ik⇩s⇩t.induct) auto
lemma ik_snd_empty'[simp]: "ik⇩s⇩t [Send t] = {}" by simp
lemma ik_append[iff]: "ik⇩s⇩t (S@S') = ik⇩s⇩t S ∪ ik⇩s⇩t S'" by (induct S rule: ik⇩s⇩t.induct) auto
lemma ik_cons: "ik⇩s⇩t (x#S) = ik⇩s⇩t [x] ∪ ik⇩s⇩t S" using ik_append[of "[x]" S] by simp
lemma assignment_rhs_append[iff]: "assignment_rhs⇩s⇩t (S@S') = assignment_rhs⇩s⇩t S ∪ assignment_rhs⇩s⇩t S'"
by (induct S rule: assignment_rhs⇩s⇩t.induct) auto
lemma eqs_rcv_map_empty: "assignment_rhs⇩s⇩t (map Receive M) = {}"
by auto
lemma ik_rcv_map: assumes "t ∈ set L" shows "t ∈ ik⇩s⇩t (map Receive L)"
proof -
{ fix L L'
have "t ∈ ik⇩s⇩t [Receive t]" by auto
hence "t ∈ ik⇩s⇩t (map Receive L@Receive t#map Receive L')" using ik_append by auto
hence "t ∈ ik⇩s⇩t (map Receive (L@t#L'))" by auto
}
thus ?thesis using assms split_list_last by force
qed
lemma ik_subst: "ik⇩s⇩t (S ⋅⇩s⇩t δ) = ik⇩s⇩t S ⋅⇩s⇩e⇩t δ"
by (induct rule: ik⇩s⇩t_induct) auto
lemma ik_rcv_map': assumes "t ∈ ik⇩s⇩t (map Receive L)" shows "t ∈ set L"
using assms by force
lemma ik_append_subset[simp]: "ik⇩s⇩t S ⊆ ik⇩s⇩t (S@S')" "ik⇩s⇩t S' ⊆ ik⇩s⇩t (S@S')"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma assignment_rhs_append_subset[simp]:
"assignment_rhs⇩s⇩t S ⊆ assignment_rhs⇩s⇩t (S@S')"
"assignment_rhs⇩s⇩t S' ⊆ assignment_rhs⇩s⇩t (S@S')"
by (induct S rule: assignment_rhs⇩s⇩t.induct) auto
lemma trms⇩s⇩t_cons: "trms⇩s⇩t (x#S) = trms⇩s⇩t⇩p x ∪ trms⇩s⇩t S" by simp
lemma trm_strand_subst_cong:
"t ∈ trms⇩s⇩t S ⟹ t ⋅ δ ∈ trms⇩s⇩t (S ⋅⇩s⇩t δ)
∨ (∃X F. Inequality X F ∈ set S ∧ t ⋅ rm_vars (set X) δ ∈ trms⇩s⇩t (S ⋅⇩s⇩t δ))"
(is "t ∈ trms⇩s⇩t S ⟹ ?P t δ S")
"t ∈ trms⇩s⇩t (S ⋅⇩s⇩t δ) ⟹ (∃t'. t = t' ⋅ δ ∧ t' ∈ trms⇩s⇩t S)
∨ (∃X F. Inequality X F ∈ set S ∧ (∃t' ∈ trms⇩p⇩a⇩i⇩r⇩s F. t = t' ⋅ rm_vars (set X) δ))"
(is "t ∈ trms⇩s⇩t (S ⋅⇩s⇩t δ) ⟹ ?Q t δ S")
proof -
show "t ∈ trms⇩s⇩t S ⟹ ?P t δ S"
proof (induction S)
case (Cons x S) show ?case
proof (cases "t ∈ trms⇩s⇩t S")
case True
hence "?P t δ S" using Cons by simp
thus ?thesis
by (cases x)
(metis (no_types, lifting) Un_iff list.set_intros(2) strand_subst_hom(2) trms⇩s⇩t_cons)+
next
case False
hence "t ∈ trms⇩s⇩t⇩p x" using Cons.prems by auto
thus ?thesis
proof (induction x)
case (Inequality X F)
hence "t ⋅ rm_vars (set X) δ ∈ trms⇩s⇩t⇩p (Inequality X F ⋅⇩s⇩t⇩p δ)"
by (induct F) (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def)
thus ?case by fastforce
qed (auto simp add: subst_apply_strand_step_def)
qed
qed simp
show "t ∈ trms⇩s⇩t (S ⋅⇩s⇩t δ) ⟹ ?Q t δ S"
proof (induction S)
case (Cons x S) show ?case
proof (cases "t ∈ trms⇩s⇩t (S ⋅⇩s⇩t δ)")
case True
hence "?Q t δ S" using Cons by simp
thus ?thesis by (cases x) force+
next
case False
hence "t ∈ trms⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ)" using Cons.prems by auto
thus ?thesis
proof (induction x)
case (Inequality X F)
hence "t ∈ trms⇩s⇩t⇩p (Inequality X F) ⋅⇩s⇩e⇩t rm_vars (set X) δ"
by (induct F) (force simp add: subst_apply_pairs_def)+
thus ?case by fastforce
qed (auto simp add: subst_apply_strand_step_def)
qed
qed simp
qed
subsection ‹Lemmata: Free Variables of Strands›
lemma fv_trm_snd_rcv[simp]: "fv⇩s⇩e⇩t (trms⇩s⇩t⇩p (Send t)) = fv t" "fv⇩s⇩e⇩t (trms⇩s⇩t⇩p (Receive t)) = fv t"
by simp_all
lemma in_strand_fv_subset: "x ∈ set S ⟹ vars⇩s⇩t⇩p x ⊆ vars⇩s⇩t S" by fastforce
lemma in_strand_fv_subset_snd: "Send t ∈ set S ⟹ fv t ⊆ ⋃(set (map fv⇩s⇩n⇩d S))" by auto
lemma in_strand_fv_subset_rcv: "Receive t ∈ set S ⟹ fv t ⊆ ⋃(set (map fv⇩r⇩c⇩v S))" by auto
lemma fv⇩s⇩n⇩dE:
assumes "v ∈ ⋃(set (map fv⇩s⇩n⇩d S))"
obtains t where "send⟨t⟩⇩s⇩t ∈ set S" "v ∈ fv t"
proof -
have "∃t. send⟨t⟩⇩s⇩t ∈ set S ∧ v ∈ fv t"
by (metis (no_types, lifting) assms UN_E empty_iff set_map strand_step.case_eq_if
fv⇩s⇩n⇩d_def strand_step.collapse(1))
thus ?thesis by (metis that)
qed
lemma fv⇩r⇩c⇩vE:
assumes "v ∈ ⋃(set (map fv⇩r⇩c⇩v S))"
obtains t where "receive⟨t⟩⇩s⇩t ∈ set S" "v ∈ fv t"
proof -
have "∃t. receive⟨t⟩⇩s⇩t ∈ set S ∧ v ∈ fv t"
by (metis (no_types, lifting) assms UN_E empty_iff set_map strand_step.case_eq_if
fv⇩r⇩c⇩v_def strand_step.collapse(2))
thus ?thesis by (metis that)
qed
lemma vars⇩s⇩t⇩pI[intro]: "x ∈ fv⇩s⇩t⇩p s ⟹ x ∈ vars⇩s⇩t⇩p s"
by (induct s rule: fv⇩s⇩t⇩p.induct) auto
lemma vars⇩s⇩tI[intro]: "x ∈ fv⇩s⇩t S ⟹ x ∈ vars⇩s⇩t S" using vars⇩s⇩t⇩pI by fastforce
lemma fv⇩s⇩t_subset_vars⇩s⇩t[simp]: "fv⇩s⇩t S ⊆ vars⇩s⇩t S" using vars⇩s⇩tI by force
lemma vars⇩s⇩t_is_fv⇩s⇩t_bvars⇩s⇩t: "vars⇩s⇩t S = fv⇩s⇩t S ∪ bvars⇩s⇩t S"
proof (induction S)
case (Cons x S) thus ?case
proof (induction x)
case (Inequality X F) thus ?case by (induct F) auto
qed auto
qed simp
lemma fv⇩s⇩t⇩p_is_subterm_trms⇩s⇩t⇩p: "x ∈ fv⇩s⇩t⇩p a ⟹ Var x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩t⇩p a)"
using var_is_subterm by (cases a) force+
lemma fv⇩s⇩t_is_subterm_trms⇩s⇩t: "x ∈ fv⇩s⇩t A ⟹ Var x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩t A)"
proof (induction A)
case (Cons a A) thus ?case using fv⇩s⇩t⇩p_is_subterm_trms⇩s⇩t⇩p by (cases "x ∈ fv⇩s⇩t A") auto
qed simp
lemma vars_st_snd_map: "vars⇩s⇩t (map Send X) = fv (Fun f X)" by auto
lemma vars_st_rcv_map: "vars⇩s⇩t (map Receive X) = fv (Fun f X)" by auto
lemma vars_snd_rcv_union:
"vars⇩s⇩t⇩p x = fv⇩s⇩n⇩d x ∪ fv⇩r⇩c⇩v x ∪ fv⇩e⇩q assign x ∪ fv⇩e⇩q check x ∪ fv⇩i⇩n⇩e⇩q x ∪ set (bvars⇩s⇩t⇩p x)"
proof (cases x)
case (Equality ac t t') thus ?thesis by (cases ac) auto
qed auto
lemma fv_snd_rcv_union:
"fv⇩s⇩t⇩p x = fv⇩s⇩n⇩d x ∪ fv⇩r⇩c⇩v x ∪ fv⇩e⇩q assign x ∪ fv⇩e⇩q check x ∪ fv⇩i⇩n⇩e⇩q x"
proof (cases x)
case (Equality ac t t') thus ?thesis by (cases ac) auto
qed auto
lemma fv_snd_rcv_empty[simp]: "fv⇩s⇩n⇩d x = {} ∨ fv⇩r⇩c⇩v x = {}" by (cases x) simp_all
lemma vars_snd_rcv_strand[iff]:
"vars⇩s⇩t (S::('a,'b) strand) =
(⋃(set (map fv⇩s⇩n⇩d S))) ∪ (⋃(set (map fv⇩r⇩c⇩v S))) ∪ (⋃(set (map (fv⇩e⇩q assign) S)))
∪ (⋃(set (map (fv⇩e⇩q check) S))) ∪ (⋃(set (map fv⇩i⇩n⇩e⇩q S))) ∪ bvars⇩s⇩t S"
unfolding bvars⇩s⇩t_def
proof (induction S)
case (Cons x S)
have "⋀s V. vars⇩s⇩t⇩p (s::('a,'b) strand_step) ∪ V =
fv⇩s⇩n⇩d s ∪ fv⇩r⇩c⇩v s ∪ fv⇩e⇩q assign s ∪ fv⇩e⇩q check s ∪ fv⇩i⇩n⇩e⇩q s ∪ set (bvars⇩s⇩t⇩p s) ∪ V"
by (metis vars_snd_rcv_union)
thus ?case using Cons.IH by (auto simp add: sup_assoc sup_left_commute)
qed simp
lemma fv_snd_rcv_strand[iff]:
"fv⇩s⇩t (S::('a,'b) strand) =
(⋃(set (map fv⇩s⇩n⇩d S))) ∪ (⋃(set (map fv⇩r⇩c⇩v S))) ∪ (⋃(set (map (fv⇩e⇩q assign) S)))
∪ (⋃(set (map (fv⇩e⇩q check) S))) ∪ (⋃(set (map fv⇩i⇩n⇩e⇩q S)))"
unfolding bvars⇩s⇩t_def
proof (induction S)
case (Cons x S)
have "⋀s V. fv⇩s⇩t⇩p (s::('a,'b) strand_step) ∪ V =
fv⇩s⇩n⇩d s ∪ fv⇩r⇩c⇩v s ∪ fv⇩e⇩q assign s ∪ fv⇩e⇩q check s ∪ fv⇩i⇩n⇩e⇩q s ∪ V"
by (metis fv_snd_rcv_union)
thus ?case using Cons.IH by (auto simp add: sup_assoc sup_left_commute)
qed simp
lemma vars_snd_rcv_strand2[iff]:
"wfrestrictedvars⇩s⇩t (S::('a,'b) strand) =
(⋃(set (map fv⇩s⇩n⇩d S))) ∪ (⋃(set (map fv⇩r⇩c⇩v S))) ∪ (⋃(set (map (fv⇩e⇩q assign) S)))"
by (induct S) (auto simp add: split: strand_step.split poscheckvariant.split)
lemma fv_snd_rcv_strand_subset[simp]:
"⋃(set (map fv⇩s⇩n⇩d S)) ⊆ fv⇩s⇩t S" "⋃(set (map fv⇩r⇩c⇩v S)) ⊆ fv⇩s⇩t S"
"⋃(set (map (fv⇩e⇩q ac) S)) ⊆ fv⇩s⇩t S" "⋃(set (map fv⇩i⇩n⇩e⇩q S)) ⊆ fv⇩s⇩t S"
"wfvarsoccs⇩s⇩t S ⊆ fv⇩s⇩t S"
proof -
show "⋃(set (map fv⇩s⇩n⇩d S)) ⊆ fv⇩s⇩t S" "⋃(set (map fv⇩r⇩c⇩v S)) ⊆ fv⇩s⇩t S" "⋃(set (map fv⇩i⇩n⇩e⇩q S)) ⊆ fv⇩s⇩t S"
using fv_snd_rcv_strand[of S] by auto
show "⋃(set (map (fv⇩e⇩q ac) S)) ⊆ fv⇩s⇩t S"
by (induct S) (auto split: strand_step.split poscheckvariant.split)
show "wfvarsoccs⇩s⇩t S ⊆ fv⇩s⇩t S"
by (induct S) (auto split: strand_step.split poscheckvariant.split)
qed
lemma vars_snd_rcv_strand_subset2[simp]:
"⋃(set (map fv⇩s⇩n⇩d S)) ⊆ wfrestrictedvars⇩s⇩t S" "⋃(set (map fv⇩r⇩c⇩v S)) ⊆ wfrestrictedvars⇩s⇩t S"
"⋃(set (map (fv⇩e⇩q assign) S)) ⊆ wfrestrictedvars⇩s⇩t S" "wfvarsoccs⇩s⇩t S ⊆ wfrestrictedvars⇩s⇩t S"
by (induction S) (auto split: strand_step.split poscheckvariant.split)
lemma wfrestrictedvars⇩s⇩t_subset_vars⇩s⇩t: "wfrestrictedvars⇩s⇩t S ⊆ vars⇩s⇩t S"
by (induction S) (auto split: strand_step.split poscheckvariant.split)
lemma subst_sends_strand_step_fv_to_img: "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) ⊆ fv⇩s⇩t⇩p x ∪ range_vars δ"
using subst_sends_fv_to_img[of _ δ]
proof (cases x)
case (Inequality X F)
let ?θ = "rm_vars (set X) δ"
have "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) ⊆ fv⇩p⇩a⇩i⇩r⇩s F ∪ range_vars ?θ"
proof (induction F)
case (Cons f F) thus ?case
using subst_sends_fv_to_img[of _ ?θ]
by (auto simp add: subst_apply_pairs_def)
qed (auto simp add: subst_apply_pairs_def)
hence "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) ⊆ fv⇩p⇩a⇩i⇩r⇩s F ∪ range_vars δ"
using rm_vars_img_subset[of "set X" δ] fv_set_mono
unfolding range_vars_alt_def by blast+
thus ?thesis using Inequality by (auto simp add: subst_apply_strand_step_def)
qed (auto simp add: subst_apply_strand_step_def)
lemma subst_sends_strand_fv_to_img: "fv⇩s⇩t (S ⋅⇩s⇩t δ) ⊆ fv⇩s⇩t S ∪ range_vars δ"
proof (induction S)
case (Cons x S)
have *: "fv⇩s⇩t (x#S ⋅⇩s⇩t δ) = fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) ∪ fv⇩s⇩t (S ⋅⇩s⇩t δ)"
"fv⇩s⇩t (x#S) ∪ range_vars δ = fv⇩s⇩t⇩p x ∪ fv⇩s⇩t S ∪ range_vars δ"
by auto
thus ?case using Cons.IH subst_sends_strand_step_fv_to_img[of x δ] by auto
qed simp
lemma ineq_apply_subst:
assumes "subst_domain δ ∩ set X = {}"
shows "(Inequality X F) ⋅⇩s⇩t⇩p δ = Inequality X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using rm_vars_apply'[OF assms] by (simp add: subst_apply_strand_step_def)
lemma fv_strand_step_subst:
assumes "P = fv⇩s⇩t⇩p ∨ P = fv⇩r⇩c⇩v ∨ P = fv⇩s⇩n⇩d ∨ P = fv⇩e⇩q ac ∨ P = fv⇩i⇩n⇩e⇩q"
and "set (bvars⇩s⇩t⇩p x) ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv⇩s⇩e⇩t (δ ` (P x)) = P (x ⋅⇩s⇩t⇩p δ)"
proof (cases x)
case (Send t)
hence "vars⇩s⇩t⇩p x = fv t" "fv⇩s⇩n⇩d x = fv t" by auto
thus ?thesis using assms Send subst_apply_fv_unfold[of _ δ] by auto
next
case (Receive t)
hence "vars⇩s⇩t⇩p x = fv t" "fv⇩r⇩c⇩v x = fv t" by auto
thus ?thesis using assms Receive subst_apply_fv_unfold[of _ δ] by auto
next
case (Equality ac' t t') show ?thesis
proof (cases "ac = ac'")
case True
hence "vars⇩s⇩t⇩p x = fv t ∪ fv t'" "fv⇩e⇩q ac x = fv t ∪ fv t'"
using Equality
by auto
thus ?thesis
using assms Equality subst_apply_fv_unfold[of _ δ] True
by auto
next
case False
hence "vars⇩s⇩t⇩p x = fv t ∪ fv t'" "fv⇩e⇩q ac x = {}"
using Equality
by auto
thus ?thesis
using assms Equality subst_apply_fv_unfold[of _ δ] False
by auto
qed
next
case (Inequality X F)
hence 1: "set X ∩ (subst_domain δ ∪ range_vars δ) = {}"
"x ⋅⇩s⇩t⇩p δ = Inequality X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
"rm_vars (set X) δ = δ"
using assms ineq_apply_subst[of δ X F] rm_vars_apply'[of δ "set X"]
unfolding range_vars_alt_def by force+
have 2: "fv⇩i⇩n⇩e⇩q x = fv⇩p⇩a⇩i⇩r⇩s F - set X" using Inequality by auto
hence "fv⇩s⇩e⇩t (δ ` fv⇩i⇩n⇩e⇩q x) = fv⇩s⇩e⇩t (δ ` fv⇩p⇩a⇩i⇩r⇩s F) - set X"
using fv⇩s⇩e⇩t_subst_img_eq[OF 1(1), of "fv⇩p⇩a⇩i⇩r⇩s F"] by simp
hence 3: "fv⇩s⇩e⇩t (δ ` fv⇩i⇩n⇩e⇩q x) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X" by (metis fv⇩p⇩a⇩i⇩r⇩s_step_subst)
have 4: "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X" using 1(2) by auto
show ?thesis
using assms(1) Inequality subst_apply_fv_unfold[of _ δ] 1(2) 2 3 4
unfolding fv⇩e⇩q_def fv⇩r⇩c⇩v_def fv⇩s⇩n⇩d_def
by (metis (no_types) Sup_empty image_empty fv⇩p⇩a⇩i⇩r⇩s.simps fv⇩s⇩e⇩t.simps
fv⇩s⇩t⇩p.simps(4) strand_step.simps(20))
qed
lemma fv_strand_subst:
assumes "P = fv⇩s⇩t⇩p ∨ P = fv⇩r⇩c⇩v ∨ P = fv⇩s⇩n⇩d ∨ P = fv⇩e⇩q ac ∨ P = fv⇩i⇩n⇩e⇩q"
and "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv⇩s⇩e⇩t (δ ` (⋃(set (map P S)))) = ⋃(set (map P (S ⋅⇩s⇩t δ)))"
using assms(2)
proof (induction S)
case (Cons x S)
hence *: "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
"set (bvars⇩s⇩t⇩p x) ∩ (subst_domain δ ∪ range_vars δ) = {}"
unfolding bvars⇩s⇩t_def by force+
hence **: "fv⇩s⇩e⇩t (δ ` P x) = P (x ⋅⇩s⇩t⇩p δ)" using fv_strand_step_subst[OF assms(1), of x δ] by auto
have "fv⇩s⇩e⇩t (δ ` (⋃(set (map P (x#S))))) = fv⇩s⇩e⇩t (δ ` P x) ∪ (⋃(set (map P ((S ⋅⇩s⇩t δ)))))"
using Cons unfolding range_vars_alt_def bvars⇩s⇩t_def by force
hence "fv⇩s⇩e⇩t (δ ` (⋃(set (map P (x#S))))) = P (x ⋅⇩s⇩t⇩p δ) ∪ fv⇩s⇩e⇩t (δ ` (⋃(set (map P S))))"
using ** by simp
thus ?case using Cons.IH[OF *(1)] unfolding bvars⇩s⇩t_def by simp
qed simp
lemma fv_strand_subst2:
assumes "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv⇩s⇩e⇩t (δ ` (wfrestrictedvars⇩s⇩t S)) = wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ)"
by (metis (no_types, lifting) assms fv⇩s⇩e⇩t.simps vars_snd_rcv_strand2 fv_strand_subst UN_Un image_Un)
lemma fv_strand_subst':
assumes "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv⇩s⇩e⇩t (δ ` (fv⇩s⇩t S)) = fv⇩s⇩t (S ⋅⇩s⇩t δ)"
by (metis assms fv_strand_subst fv⇩s⇩t_def)
lemma fv_trms⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s:
"fv⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) = fv⇩p⇩a⇩i⇩r⇩s F"
by auto
lemma fv⇩p⇩a⇩i⇩r⇩s_in_fv_trms⇩p⇩a⇩i⇩r⇩s: "x ∈ fv⇩p⇩a⇩i⇩r⇩s F ⟹ x ∈ fv⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F)"
using fv_trms⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s[of F] by blast
lemma trms⇩s⇩t_append: "trms⇩s⇩t (A@B) = trms⇩s⇩t A ∪ trms⇩s⇩t B"
by auto
lemma trms⇩p⇩a⇩i⇩r⇩s_subst: "trms⇩p⇩a⇩i⇩r⇩s (a ⋅⇩p⇩a⇩i⇩r⇩s θ) = trms⇩p⇩a⇩i⇩r⇩s a ⋅⇩s⇩e⇩t θ"
by (auto simp add: subst_apply_pairs_def)
lemma trms⇩p⇩a⇩i⇩r⇩s_fv_subst_subset:
"t ∈ trms⇩p⇩a⇩i⇩r⇩s F ⟹ fv (t ⋅ θ) ⊆ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ)"
by (force simp add: subst_apply_pairs_def)
lemma trms⇩p⇩a⇩i⇩r⇩s_fv_subst_subset':
fixes t::"('a,'b) term" and θ::"('a,'b) subst"
assumes "t ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F)"
shows "fv (t ⋅ θ) ⊆ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ)"
proof -
{ fix x assume "x ∈ fv t"
hence "x ∈ fv⇩p⇩a⇩i⇩r⇩s F"
using fv_subset[OF assms] fv_subterms_set[of "trms⇩p⇩a⇩i⇩r⇩s F"] fv_trms⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s[of F]
by blast
hence "fv (θ x) ⊆ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ)" using fv⇩p⇩a⇩i⇩r⇩s_subst_fv_subset by fast
} thus ?thesis by (meson fv_subst_obtain_var subset_iff)
qed
lemma trms⇩p⇩a⇩i⇩r⇩s_funs_term_cases:
assumes "t ∈ trms⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ)" "f ∈ funs_term t"
shows "(∃u ∈ trms⇩p⇩a⇩i⇩r⇩s F. f ∈ funs_term u) ∨ (∃x ∈ fv⇩p⇩a⇩i⇩r⇩s F. f ∈ funs_term (θ x))"
using assms(1)
proof (induction F)
case (Cons g F)
obtain s u where g: "g = (s,u)" by (metis surj_pair)
show ?case
proof (cases "t ∈ trms⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ)")
case False
thus ?thesis
using assms(2) Cons.prems g funs_term_subst[of _ θ]
by (auto simp add: subst_apply_pairs_def)
qed (use Cons.IH in fastforce)
qed simp
lemma trm⇩s⇩t⇩p_subst:
assumes "subst_domain θ ∩ set (bvars⇩s⇩t⇩p a) = {}"
shows "trms⇩s⇩t⇩p (a ⋅⇩s⇩t⇩p θ) = trms⇩s⇩t⇩p a ⋅⇩s⇩e⇩t θ"
proof -
have "rm_vars (set (bvars⇩s⇩t⇩p a)) θ = θ" using assms by force
thus ?thesis
using assms
by (auto simp add: subst_apply_pairs_def subst_apply_strand_step_def
split: strand_step.splits)
qed
lemma trms⇩s⇩t_subst:
assumes "subst_domain θ ∩ bvars⇩s⇩t A = {}"
shows "trms⇩s⇩t (A ⋅⇩s⇩t θ) = trms⇩s⇩t A ⋅⇩s⇩e⇩t θ"
using assms
proof (induction A)
case (Cons a A)
have 1: "subst_domain θ ∩ bvars⇩s⇩t A = {}" "subst_domain θ ∩ set (bvars⇩s⇩t⇩p a) = {}"
using Cons.prems by auto
hence IH: "trms⇩s⇩t A ⋅⇩s⇩e⇩t θ = trms⇩s⇩t (A ⋅⇩s⇩t θ)" using Cons.IH by simp
have "trms⇩s⇩t (a#A) = trms⇩s⇩t⇩p a ∪ trms⇩s⇩t A" by auto
hence 2: "trms⇩s⇩t (a#A) ⋅⇩s⇩e⇩t θ = (trms⇩s⇩t⇩p a ⋅⇩s⇩e⇩t θ) ∪ (trms⇩s⇩t A ⋅⇩s⇩e⇩t θ)" by (metis image_Un)
have "trms⇩s⇩t (a#A ⋅⇩s⇩t θ) = (trms⇩s⇩t⇩p (a ⋅⇩s⇩t⇩p θ)) ∪ trms⇩s⇩t (A ⋅⇩s⇩t θ)"
by (auto simp add: subst_apply_strand_def)
hence 3: "trms⇩s⇩t (a#A ⋅⇩s⇩t θ) = (trms⇩s⇩t⇩p a ⋅⇩s⇩e⇩t θ) ∪ trms⇩s⇩t (A ⋅⇩s⇩t θ)"
using trm⇩s⇩t⇩p_subst[OF 1(2)] by auto
show ?case using IH 2 3 by metis
qed (simp add: subst_apply_strand_def)
lemma strand_map_set_subst:
assumes δ: "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "⋃(set (map trms⇩s⇩t⇩p (S ⋅⇩s⇩t δ))) = (⋃(set (map trms⇩s⇩t⇩p S))) ⋅⇩s⇩e⇩t δ"
using assms
proof (induction S)
case (Cons x S)
hence "bvars⇩s⇩t [x] ∩ subst_domain δ = {}" "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
unfolding bvars⇩s⇩t_def by force+
hence *: "subst_domain δ ∩ set (bvars⇩s⇩t⇩p x) = {}"
"⋃(set (map trms⇩s⇩t⇩p (S ⋅⇩s⇩t δ))) = ⋃(set (map trms⇩s⇩t⇩p S)) ⋅⇩s⇩e⇩t δ"
using Cons.IH(1) bvars⇩s⇩t_singleton[of x] by auto
hence "trms⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = (trms⇩s⇩t⇩p x) ⋅⇩s⇩e⇩t δ"
proof (cases x)
case (Inequality X F)
thus ?thesis
using rm_vars_apply'[of δ "set X"] *
by (metis (no_types, lifting) image_cong trm⇩s⇩t⇩p_subst)
qed simp_all
thus ?case using * subst_all_insert by auto
qed simp
lemma subst_apply_fv_subset_strand_trm:
assumes P: "P = fv⇩s⇩t⇩p ∨ P = fv⇩r⇩c⇩v ∨ P = fv⇩s⇩n⇩d ∨ P = fv⇩e⇩q ac ∨ P = fv⇩i⇩n⇩e⇩q"
and fv_sub: "fv t ⊆ ⋃(set (map P S)) ∪ V"
and δ: "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv (t ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
using fv_strand_subst[OF P δ] subst_apply_fv_subset[OF fv_sub, of δ] by force
lemma subst_apply_fv_subset_strand_trm2:
assumes fv_sub: "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V"
and δ: "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv (t ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using fv_strand_subst2[OF δ] subst_apply_fv_subset[OF fv_sub, of δ] by force
lemma subst_apply_fv_subset_strand:
assumes P: "P = fv⇩s⇩t⇩p ∨ P = fv⇩r⇩c⇩v ∨ P = fv⇩s⇩n⇩d ∨ P = fv⇩e⇩q ac ∨ P = fv⇩i⇩n⇩e⇩q"
and P_subset: "P x ⊆ ⋃(set (map P S)) ∪ V"
and δ: "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
"set (bvars⇩s⇩t⇩p x) ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "P (x ⋅⇩s⇩t⇩p δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
proof (cases x)
case (Send t)
hence *: "fv⇩s⇩t⇩p x = fv t" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = fv t" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
by auto
hence **: "(P x = fv t ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)) ∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})" by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
hence "fv t ⊆ ⋃(set (map P S)) ∪ V" using P_subset by auto
hence "fv (t ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
unfolding vars⇩s⇩t_def using P subst_apply_fv_subset_strand_trm assms by blast
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)› by force
}
ultimately show ?thesis by metis
next
case (Receive t)
hence *: "fv⇩s⇩t⇩p x = fv t" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩r⇩c⇩v x = fv t" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
by auto
hence **: "(P x = fv t ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)) ∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})" by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
hence "fv t ⊆ ⋃(set (map P S)) ∪ V" using P_subset by auto
hence "fv (t ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
unfolding vars⇩s⇩t_def using P subst_apply_fv_subset_strand_trm assms by blast
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)› by blast
}
ultimately show ?thesis by metis
next
case (Equality ac' t t') show ?thesis
proof (cases "ac' = ac")
case True
hence *: "fv⇩s⇩t⇩p x = fv t ∪ fv t'" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = fv t ∪ fv t'" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
using Equality by auto
hence **: "(P x = fv t ∪ fv t' ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ))
∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})"
by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t ∪ fv t'" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
hence "fv t ⊆ ⋃(set (map P S)) ∪ V" "fv t' ⊆ ⋃(set (map P S)) ∪ V" using P_subset by auto
hence "fv (t ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
"fv (t' ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
unfolding vars⇩s⇩t_def using P subst_apply_fv_subset_strand_trm assms by metis+
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)› by blast
}
ultimately show ?thesis by metis
next
case False
hence *: "fv⇩s⇩t⇩p x = fv t ∪ fv t'" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
using Equality by auto
hence **: "(P x = fv t ∪ fv t' ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ))
∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})"
by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t ∪ fv t'" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
hence "fv t ⊆ ⋃(set (map P S)) ∪ V" "fv t' ⊆ ⋃(set (map P S)) ∪ V" using P_subset by auto
hence "fv (t ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
"fv (t' ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
unfolding vars⇩s⇩t_def using P subst_apply_fv_subset_strand_trm assms by metis+
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)› by blast
}
ultimately show ?thesis by metis
qed
next
case (Inequality X F)
hence *: "fv⇩s⇩t⇩p x = fv⇩p⇩a⇩i⇩r⇩s F - set X" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = fv⇩p⇩a⇩i⇩r⇩s F - set X"
"fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X"
using δ(2) ineq_apply_subst[of δ X F] by force+
hence **: "(P x = fv⇩p⇩a⇩i⇩r⇩s F - set X ∧ P (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X)
∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})"
by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv⇩p⇩a⇩i⇩r⇩s F - set X" "P (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X"
hence "fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ ⋃(set (map P S)) ∪ V"
using P_subset by auto
hence "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
proof (induction F)
case (Cons f G)
hence IH: "fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
by (metis (no_types, lifting) Diff_subset_conv UN_insert le_sup_iff
list.simps(15) fv⇩p⇩a⇩i⇩r⇩s.simps)
obtain t t' where f: "f = (t,t')" by (metis surj_pair)
hence "fv t ⊆ ⋃(set (map P S)) ∪ (V ∪ set X)" "fv t' ⊆ ⋃(set (map P S)) ∪ (V ∪ set X)"
using Cons.prems by auto
hence "fv (t ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
"fv (t' ⋅ δ) ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
using subst_apply_fv_subset_strand_trm[OF P _ assms(3)]
by blast+
thus ?case using f IH by (auto simp add: subst_apply_pairs_def)
qed (simp add: subst_apply_pairs_def)
moreover have "fv⇩s⇩e⇩t (δ ` set X) = set X" using assms(4) Inequality by force
ultimately have "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X ⊆ ⋃(set (map P (S ⋅⇩s⇩t δ))) ∪ fv⇩s⇩e⇩t (δ ` V)"
by auto
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X› by blast
}
ultimately show ?thesis by metis
qed
lemma subst_apply_fv_subset_strand2:
assumes P: "P = fv⇩s⇩t⇩p ∨ P = fv⇩r⇩c⇩v ∨ P = fv⇩s⇩n⇩d ∨ P = fv⇩e⇩q ac ∨ P = fv⇩i⇩n⇩e⇩q ∨ P = fv_r⇩e⇩q ac"
and P_subset: "P x ⊆ wfrestrictedvars⇩s⇩t S ∪ V"
and δ: "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
"set (bvars⇩s⇩t⇩p x) ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "P (x ⋅⇩s⇩t⇩p δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
proof (cases x)
case (Send t)
hence *: "fv⇩s⇩t⇩p x = fv t" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = fv t" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
"fv_r⇩e⇩q ac x = {}" "fv_r⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
by auto
hence **: "(P x = fv t ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)) ∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})" by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
hence "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V" using P_subset by auto
hence "fv (t ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using P subst_apply_fv_subset_strand_trm2 assms by blast
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)› by blast
}
ultimately show ?thesis by metis
next
case (Receive t)
hence *: "fv⇩s⇩t⇩p x = fv t" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩r⇩c⇩v x = fv t" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
"fv_r⇩e⇩q ac x = {}" "fv_r⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
by auto
hence **: "(P x = fv t ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)) ∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})" by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)"
hence "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V" using P_subset by auto
hence "fv (t ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using P subst_apply_fv_subset_strand_trm2 assms by blast
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ)› by blast
}
ultimately show ?thesis by metis
next
case (Equality ac' t t') show ?thesis
proof (cases "ac' = ac")
case True
hence *: "fv⇩s⇩t⇩p x = fv t ∪ fv t'" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = fv t ∪ fv t'" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
"fv_r⇩e⇩q ac x = fv t'" "fv_r⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = fv (t' ⋅ δ)"
using Equality by auto
hence **: "(P x = fv t ∪ fv t' ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ))
∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})
∨ (P x = fv t' ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t' ⋅ δ))"
by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t ∪ fv t'" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
hence "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V" "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V" using P_subset by auto
hence "fv (t ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
"fv (t' ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using P subst_apply_fv_subset_strand_trm2 assms by blast+
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)› by blast
}
moreover
{ assume "P x = fv t'" "P (x ⋅⇩s⇩t⇩p δ) = fv (t' ⋅ δ)"
hence "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V" using P_subset by auto
hence "fv (t' ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using P subst_apply_fv_subset_strand_trm2 assms by blast+
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t' ⋅ δ)› by blast
}
ultimately show ?thesis by metis
next
case False
hence *: "fv⇩s⇩t⇩p x = fv t ∪ fv t'" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = {}" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = {}"
"fv_r⇩e⇩q ac x = {}" "fv_r⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
using Equality by auto
hence **: "(P x = fv t ∪ fv t' ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ))
∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})
∨ (P x = fv t' ∧ P (x ⋅⇩s⇩t⇩p δ) = fv (t' ⋅ δ))"
by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv t ∪ fv t'" "P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)"
hence "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V" "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V"
using P_subset by auto
hence "fv (t ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
"fv (t' ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using P subst_apply_fv_subset_strand_trm2 assms by blast+
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ)› by blast
}
moreover
{ assume "P x = fv t'" "P (x ⋅⇩s⇩t⇩p δ) = fv (t' ⋅ δ)"
hence "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V" using P_subset by auto
hence "fv (t' ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using P subst_apply_fv_subset_strand_trm2 assms by blast+
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv (t' ⋅ δ)› by blast
}
ultimately show ?thesis by metis
qed
next
case (Inequality X F)
hence *: "fv⇩s⇩t⇩p x = fv⇩p⇩a⇩i⇩r⇩s F - set X" "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X"
"fv⇩r⇩c⇩v x = {}" "fv⇩r⇩c⇩v (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩s⇩n⇩d x = {}" "fv⇩s⇩n⇩d (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩e⇩q ac x = {}" "fv⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
"fv⇩i⇩n⇩e⇩q x = fv⇩p⇩a⇩i⇩r⇩s F - set X" "fv⇩i⇩n⇩e⇩q (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X"
"fv_r⇩e⇩q ac x = {}" "fv_r⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ) = {}"
using δ(2) ineq_apply_subst[of δ X F] by force+
hence **: "(P x = fv⇩p⇩a⇩i⇩r⇩s F - set X ∧ P (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X)
∨ (P x = {} ∧ P (x ⋅⇩s⇩t⇩p δ) = {})"
by (metis P)
moreover
{ assume "P x = {}" "P (x ⋅⇩s⇩t⇩p δ) = {}" hence ?thesis by simp }
moreover
{ assume "P x = fv⇩p⇩a⇩i⇩r⇩s F - set X" "P (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X"
hence "fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ wfrestrictedvars⇩s⇩t S ∪ V" using P_subset by auto
hence "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
proof (induction F)
case (Cons f G)
hence IH: "fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
by (metis (no_types, lifting) Diff_subset_conv UN_insert le_sup_iff
list.simps(15) fv⇩p⇩a⇩i⇩r⇩s.simps)
obtain t t' where f: "f = (t,t')" by (metis surj_pair)
hence "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ (V ∪ set X)" "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ (V ∪ set X)"
using Cons.prems by auto
hence "fv (t ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
"fv (t' ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` (V ∪ set X))"
using subst_apply_fv_subset_strand_trm2[OF _ assms(3)] P
by blast+
thus ?case using f IH by (auto simp add: subst_apply_pairs_def)
qed (simp add: subst_apply_pairs_def)
moreover have "fv⇩s⇩e⇩t (δ ` set X) = set X" using assms(4) Inequality by force
ultimately have "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
by fastforce
hence ?thesis using ‹P (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) - set X› by blast
}
ultimately show ?thesis by metis
qed
lemma strand_subst_fv_bounded_if_img_bounded:
assumes "range_vars δ ⊆ fv⇩s⇩t S"
shows "fv⇩s⇩t (S ⋅⇩s⇩t δ) ⊆ fv⇩s⇩t S"
using subst_sends_strand_fv_to_img[of S δ] assms by blast
lemma strand_fv_subst_subset_if_subst_elim:
assumes "subst_elim δ v" and "v ∈ fv⇩s⇩t S ∨ bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "v ∉ fv⇩s⇩t (S ⋅⇩s⇩t δ)"
proof (cases "v ∈ fv⇩s⇩t S")
case True thus ?thesis
proof (induction S)
case (Cons x S)
have *: "v ∉ fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ)"
using assms(1)
proof (cases x)
case (Inequality X F)
hence "subst_elim (rm_vars (set X) δ) v ∨ v ∈ set X" using assms(1) by blast
moreover have "fv⇩s⇩t⇩p (Inequality X F ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ) - set X"
using Inequality by auto
ultimately have "v ∉ fv⇩s⇩t⇩p (Inequality X F ⋅⇩s⇩t⇩p δ)"
by (induct F) (auto simp add: subst_elim_def subst_apply_pairs_def)
thus ?thesis using Inequality by simp
qed (simp_all add: subst_elim_def)
moreover have "v ∉ fv⇩s⇩t (S ⋅⇩s⇩t δ)" using Cons.IH
proof (cases "v ∈ fv⇩s⇩t S")
case False
moreover have "v ∉ range_vars δ"
by (simp add: subst_elimD''[OF assms(1)] range_vars_alt_def)
ultimately show ?thesis by (meson UnE subsetCE subst_sends_strand_fv_to_img)
qed simp
ultimately show ?case by auto
qed simp
next
case False
thus ?thesis
using assms fv_strand_subst'
unfolding subst_elim_def
by (metis (mono_tags, hide_lams) fv⇩s⇩e⇩t.simps imageE mem_simps(8) subst_apply_term.simps(1))
qed
lemma strand_fv_subst_subset_if_subst_elim':
assumes "subst_elim δ v" "v ∈ fv⇩s⇩t S" "range_vars δ ⊆ fv⇩s⇩t S"
shows "fv⇩s⇩t (S ⋅⇩s⇩t δ) ⊂ fv⇩s⇩t S"
using strand_fv_subst_subset_if_subst_elim[OF assms(1)] assms(2)
strand_subst_fv_bounded_if_img_bounded[OF assms(3)]
by blast
lemma fv_ik_is_fv_rcv: "fv⇩s⇩e⇩t (ik⇩s⇩t S) = ⋃(set (map fv⇩r⇩c⇩v S))"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma fv_ik_subset_fv_st[simp]: "fv⇩s⇩e⇩t (ik⇩s⇩t S) ⊆ wfrestrictedvars⇩s⇩t S"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma fv_assignment_rhs_subset_fv_st[simp]: "fv⇩s⇩e⇩t (assignment_rhs⇩s⇩t S) ⊆ wfrestrictedvars⇩s⇩t S"
by (induct S rule: assignment_rhs⇩s⇩t.induct) force+
lemma fv_ik_subset_fv_st'[simp]: "fv⇩s⇩e⇩t (ik⇩s⇩t S) ⊆ fv⇩s⇩t S"
by (induct S rule: ik⇩s⇩t.induct) auto
lemma ik⇩s⇩t_var_is_fv: "Var x ∈ subterms⇩s⇩e⇩t (ik⇩s⇩t A) ⟹ x ∈ fv⇩s⇩t A"
by (meson fv_ik_subset_fv_st'[of A] fv_subset_subterms subsetCE term.set_intros(3))
lemma fv_assignment_rhs_subset_fv_st'[simp]: "fv⇩s⇩e⇩t (assignment_rhs⇩s⇩t S) ⊆ fv⇩s⇩t S"
by (induct S rule: assignment_rhs⇩s⇩t.induct) auto
lemma ik⇩s⇩t_assignment_rhs⇩s⇩t_wfrestrictedvars_subset:
"fv⇩s⇩e⇩t (ik⇩s⇩t A ∪ assignment_rhs⇩s⇩t A) ⊆ wfrestrictedvars⇩s⇩t A"
using fv_ik_subset_fv_st[of A] fv_assignment_rhs_subset_fv_st[of A]
by simp+
lemma strand_step_id_subst[iff]: "x ⋅⇩s⇩t⇩p Var = x" by (cases x) auto
lemma strand_id_subst[iff]: "S ⋅⇩s⇩t Var = S" using strand_step_id_subst by (induct S) auto
lemma strand_subst_vars_union_bound[simp]: "vars⇩s⇩t (S ⋅⇩s⇩t δ) ⊆ vars⇩s⇩t S ∪ range_vars δ"
proof (induction S)
case (Cons x S)
moreover have "vars⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) ⊆ vars⇩s⇩t⇩p x ∪ range_vars δ" using subst_sends_fv_to_img[of _ δ]
proof (cases x)
case (Inequality X F)
define δ' where "δ' ≡ rm_vars (set X) δ"
have 0: "range_vars δ' ⊆ range_vars δ"
using rm_vars_img[of "set X" δ]
by (auto simp add: δ'_def subst_domain_def range_vars_alt_def)
have "vars⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) = fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ') ∪ set X" "vars⇩s⇩t⇩p x = fv⇩p⇩a⇩i⇩r⇩s F ∪ set X"
using Inequality by (auto simp add: δ'_def)
moreover have "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ') ⊆ fv⇩p⇩a⇩i⇩r⇩s F ∪ range_vars δ"
proof (induction F)
case (Cons f G)
obtain t t' where f: "f = (t,t')" by moura
hence "fv⇩p⇩a⇩i⇩r⇩s (f#G ⋅⇩p⇩a⇩i⇩r⇩s δ') = fv (t ⋅ δ') ∪ fv (t' ⋅ δ') ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s δ')"
"fv⇩p⇩a⇩i⇩r⇩s (f#G) = fv t ∪ fv t' ∪ fv⇩p⇩a⇩i⇩r⇩s G"
by (auto simp add: subst_apply_pairs_def)
thus ?case
using 0 Cons.IH subst_sends_fv_to_img[of t δ'] subst_sends_fv_to_img[of t' δ']
unfolding f by auto
qed (simp add: subst_apply_pairs_def)
ultimately show ?thesis by auto
qed auto
ultimately show ?case by auto
qed simp
lemma strand_vars_split:
"vars⇩s⇩t (S@S') = vars⇩s⇩t S ∪ vars⇩s⇩t S'"
"wfrestrictedvars⇩s⇩t (S@S') = wfrestrictedvars⇩s⇩t S ∪ wfrestrictedvars⇩s⇩t S'"
"fv⇩s⇩t (S@S') = fv⇩s⇩t S ∪ fv⇩s⇩t S'"
by auto
lemma bvars_subst_ident: "bvars⇩s⇩t S = bvars⇩s⇩t (S ⋅⇩s⇩t δ)"
unfolding bvars⇩s⇩t_def
by (induct S) (simp_all add: subst_apply_strand_step_def split: strand_step.splits)
lemma strand_subst_subst_idem:
assumes "subst_idem δ" "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t S" "subst_domain θ ∩ fv⇩s⇩t S = {}"
"range_vars δ ∩ bvars⇩s⇩t S = {}" "range_vars θ ∩ bvars⇩s⇩t S = {}"
shows "(S ⋅⇩s⇩t δ) ⋅⇩s⇩t θ = (S ⋅⇩s⇩t δ)"
and "(S ⋅⇩s⇩t δ) ⋅⇩s⇩t (θ ∘⇩s δ) = (S ⋅⇩s⇩t δ)"
proof -
from assms(2,3) have "fv⇩s⇩t (S ⋅⇩s⇩t δ) ∩ subst_domain θ = {}"
using subst_sends_strand_fv_to_img[of S δ] by blast
thus "(S ⋅⇩s⇩t δ) ⋅⇩s⇩t θ = (S ⋅⇩s⇩t δ)" by blast
thus "(S ⋅⇩s⇩t δ) ⋅⇩s⇩t (θ ∘⇩s δ) = (S ⋅⇩s⇩t δ)"
by (metis assms(1,4,5) bvars_subst_ident strand_subst_comp subst_idem_def)
qed
lemma strand_subst_img_bound:
assumes "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t S"
and "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "range_vars δ ⊆ fv⇩s⇩t (S ⋅⇩s⇩t δ)"
proof -
have "subst_domain δ ⊆ ⋃(set (map fv⇩s⇩t⇩p S))" by (metis (no_types) fv⇩s⇩t_def Un_subset_iff assms(1))
thus ?thesis
unfolding range_vars_alt_def fv⇩s⇩t_def
by (metis subst_range.simps fv_set_mono fv_strand_subst Int_commute assms(2) image_Un
le_iff_sup)
qed
lemma strand_subst_img_bound':
assumes "subst_domain δ ∪ range_vars δ ⊆ vars⇩s⇩t S"
and "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "range_vars δ ⊆ vars⇩s⇩t (S ⋅⇩s⇩t δ)"
proof -
have "(subst_domain δ ∪ fv⇩s⇩e⇩t (δ ` subst_domain δ)) ∩ vars⇩s⇩t S =
subst_domain δ ∪ fv⇩s⇩e⇩t (δ ` subst_domain δ)"
using assms(1) by (metis inf.absorb_iff1 range_vars_alt_def subst_range.simps)
hence "range_vars δ ⊆ fv⇩s⇩t (S ⋅⇩s⇩t δ)"
using vars_snd_rcv_strand fv_snd_rcv_strand assms(2) strand_subst_img_bound
unfolding range_vars_alt_def
by (metis (no_types) inf_le2 inf_sup_distrib1 subst_range.simps sup_bot.right_neutral)
thus "range_vars δ ⊆ vars⇩s⇩t (S ⋅⇩s⇩t δ)"
by (metis fv_snd_rcv_strand le_supI1 vars_snd_rcv_strand)
qed
lemma strand_subst_all_fv_subset:
assumes "fv t ⊆ fv⇩s⇩t S" "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "fv (t ⋅ δ) ⊆ fv⇩s⇩t (S ⋅⇩s⇩t δ)"
using assms by (metis fv_strand_subst' Int_commute subst_apply_fv_subset)
lemma strand_subst_not_dom_fixed:
assumes "v ∈ fv⇩s⇩t S" and "v ∉ subst_domain δ"
shows "v ∈ fv⇩s⇩t (S ⋅⇩s⇩t δ)"
using assms
proof (induction S)
case (Cons x S')
have 1: "⋀X. v ∉ subst_domain (rm_vars (set X) δ)"
using Cons.prems(2) rm_vars_dom_subset by force
show ?case
proof (cases "v ∈ fv⇩s⇩t S'")
case True thus ?thesis using Cons.IH[OF _ Cons.prems(2)] by auto
next
case False
hence 2: "v ∈ fv⇩s⇩t⇩p x" using Cons.prems(1) by simp
hence "v ∈ fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ)" using Cons.prems(2) subst_not_dom_fixed
proof (cases x)
case (Inequality X F)
hence "v ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X" using 2 by simp
hence "v ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ)"
using subst_not_dom_fixed[OF _ 1]
by (induct F) (auto simp add: subst_apply_pairs_def)
thus ?thesis using Inequality 2 by auto
qed (force simp add: subst_domain_def)+
thus ?thesis by auto
qed
qed simp
lemma strand_vars_unfold: "v ∈ vars⇩s⇩t S ⟹ ∃S' x S''. S = S'@x#S'' ∧ v ∈ vars⇩s⇩t⇩p x"
proof (induction S)
case (Cons x S) thus ?case
proof (cases "v ∈ vars⇩s⇩t⇩p x")
case True thus ?thesis by blast
next
case False
hence "v ∈ vars⇩s⇩t S" using Cons.prems by auto
thus ?thesis using Cons.IH by (metis append_Cons)
qed
qed simp
lemma strand_fv_unfold: "v ∈ fv⇩s⇩t S ⟹ ∃S' x S''. S = S'@x#S'' ∧ v ∈ fv⇩s⇩t⇩p x"
proof (induction S)
case (Cons x S) thus ?case
proof (cases "v ∈ fv⇩s⇩t⇩p x")
case True thus ?thesis by blast
next
case False
hence "v ∈ fv⇩s⇩t S" using Cons.prems by auto
thus ?thesis using Cons.IH by (metis append_Cons)
qed
qed simp
lemma subterm_if_in_strand_ik:
"t ∈ ik⇩s⇩t S ⟹ ∃t'. Receive t' ∈ set S ∧ t ⊑ t'"
by (induct S rule: ik⇩s⇩t_induct) auto
lemma fv_subset_if_in_strand_ik:
"t ∈ ik⇩s⇩t S ⟹ fv t ⊆ ⋃(set (map fv⇩r⇩c⇩v S))"
proof -
assume "t ∈ ik⇩s⇩t S"
then obtain t' where "Receive t' ∈ set S" "t ⊑ t'" by (metis subterm_if_in_strand_ik)
hence "fv t ⊆ fv t'" by (simp add: subtermeq_vars_subset)
thus ?thesis using in_strand_fv_subset_rcv[OF ‹Receive t' ∈ set S›] by auto
qed
lemma fv_subset_if_in_strand_ik':
"t ∈ ik⇩s⇩t S ⟹ fv t ⊆ fv⇩s⇩t S"
using fv_subset_if_in_strand_ik[of t S] fv_snd_rcv_strand_subset(2)[of S] by blast
lemma vars_subset_if_in_strand_ik2:
"t ∈ ik⇩s⇩t S ⟹ fv t ⊆ wfrestrictedvars⇩s⇩t S"
using fv_subset_if_in_strand_ik[of t S] vars_snd_rcv_strand_subset2(2)[of S] by blast
subsection ‹Lemmata: Simple Strands›
lemma simple_Cons[dest]: "simple (s#S) ⟹ simple S"
unfolding simple_def by auto
lemma simple_split[dest]:
assumes "simple (S@S')"
shows "simple S" "simple S'"
using assms unfolding simple_def by auto
lemma simple_append[intro]: "⟦simple S; simple S'⟧ ⟹ simple (S@S')"
unfolding simple_def by auto
lemma simple_append_sym[sym]: "simple (S@S') ⟹ simple (S'@S)" by auto
lemma not_simple_if_snd_fun: "(∃S' S'' f X. S = S'@Send (Fun f X)#S'') ⟹ ¬simple S"
unfolding simple_def by auto
lemma not_list_all_elim: "¬list_all P A ⟹ ∃B x C. A = B@x#C ∧ ¬P x ∧ list_all P B"
proof (induction A rule: List.rev_induct)
case (snoc a A)
show ?case
proof (cases "list_all P A")
case True
thus ?thesis using snoc.prems by auto
next
case False
then obtain B x C where "A = B@x#C" "¬P x" "list_all P B" using snoc.IH[OF False] by auto
thus ?thesis by auto
qed
qed simp
lemma not_simple⇩s⇩t⇩p_elim:
assumes "¬simple⇩s⇩t⇩p x"
shows "(∃f T. x = Send (Fun f T)) ∨
(∃a t t'. x = Equality a t t') ∨
(∃X F. x = Inequality X F ∧ ¬(∃ℐ. ineq_model ℐ X F))"
using assms by (cases x) (fastforce elim: simple⇩s⇩t⇩p.elims)+
lemma not_simple_elim:
assumes "¬simple S"
shows "(∃A B f T. S = A@Send (Fun f T)#B ∧ simple A) ∨
(∃A B a t t'. S = A@Equality a t t'#B ∧ simple A) ∨
(∃A B X F. S = A@Inequality X F#B ∧ ¬(∃ℐ. ineq_model ℐ X F))"
by (metis assms not_list_all_elim not_simple⇩s⇩t⇩p_elim simple_def)
lemma simple_fun_prefix_unique:
assumes "A = S@Send (Fun f X)#S'" "simple S"
shows "∀T g Y T'. A = T@Send (Fun g Y)#T' ∧ simple T ⟶ S = T ∧ f = g ∧ X = Y ∧ S' = T'"
proof -
{ fix T g Y T' assume *: "A = T@Send (Fun g Y)#T'" "simple T"
{ assume "length S < length T" hence False using assms *
by (metis id_take_nth_drop not_simple_if_snd_fun nth_append nth_append_length)
}
moreover
{ assume "length S > length T" hence False using assms *
by (metis id_take_nth_drop not_simple_if_snd_fun nth_append nth_append_length)
}
ultimately have "S = T" using assms * by (meson List.append_eq_append_conv linorder_neqE_nat)
}
thus ?thesis using assms(1) by blast
qed
lemma simple_snd_is_var: "⟦Send t ∈ set S; simple S⟧ ⟹ ∃v. t = Var v"
unfolding simple_def
by (metis list_all_append list_all_simps(1) simple⇩s⇩t⇩p.elims(2) split_list_first
strand_step.distinct(1) strand_step.distinct(5) strand_step.inject(1))
subsection ‹Lemmata: Strand Measure›
lemma measure⇩s⇩t_wellfounded: "wf measure⇩s⇩t" unfolding measure⇩s⇩t_def by simp
lemma strand_size_append[iff]: "size⇩s⇩t (S@S') = size⇩s⇩t S + size⇩s⇩t S'"
by (induct S) (auto simp add: size⇩s⇩t_def)
lemma strand_size_map_fun_lt[simp]:
"size⇩s⇩t (map Send X) < size (Fun f X)"
"size⇩s⇩t (map Send X) < size⇩s⇩t [Send (Fun f X)]"
"size⇩s⇩t (map Send X) < size⇩s⇩t [Receive (Fun f X)]"
by (induct X) (auto simp add: size⇩s⇩t_def)
lemma strand_size_rm_fun_lt[simp]:
"size⇩s⇩t (S@S') < size⇩s⇩t (S@Send (Fun f X)#S')"
"size⇩s⇩t (S@S') < size⇩s⇩t (S@Receive (Fun f X)#S')"
by (induct S) (auto simp add: size⇩s⇩t_def)
lemma strand_fv_card_map_fun_eq:
"card (fv⇩s⇩t (S@Send (Fun f X)#S')) = card (fv⇩s⇩t (S@(map Send X)@S'))"
proof -
have "fv⇩s⇩t (S@Send (Fun f X)#S') = fv⇩s⇩t (S@(map Send X)@S')" by auto
thus ?thesis by simp
qed
lemma strand_fv_card_rm_fun_le[simp]: "card (fv⇩s⇩t (S@S')) ≤ card (fv⇩s⇩t (S@Send (Fun f X)#S'))"
by (force intro: card_mono)
lemma strand_fv_card_rm_eq_le[simp]: "card (fv⇩s⇩t (S@S')) ≤ card (fv⇩s⇩t (S@Equality a t t'#S'))"
by (force intro: card_mono)
subsection ‹Lemmata: Well-formed Strands›
lemma wf_prefix[dest]: "wf⇩s⇩t V (S@S') ⟹ wf⇩s⇩t V S"
by (induct S rule: wf⇩s⇩t.induct) auto
lemma wf_vars_mono[simp]: "wf⇩s⇩t V S ⟹ wf⇩s⇩t (V ∪ W) S"
proof (induction S arbitrary: V)
case (Cons x S) thus ?case
proof (cases x)
case (Send t)
hence "wf⇩s⇩t (V ∪ fv t ∪ W) S" using Cons.prems(1) Cons.IH by simp
thus ?thesis using Send by (simp add: sup_commute sup_left_commute)
next
case (Equality a t t')
show ?thesis
proof (cases a)
case Assign
hence "wf⇩s⇩t (V ∪ fv t ∪ W) S" "fv t' ⊆ V ∪ W" using Equality Cons.prems(1) Cons.IH by auto
thus ?thesis using Equality Assign by (simp add: sup_commute sup_left_commute)
next
case Check thus ?thesis using Equality Cons by auto
qed
qed auto
qed simp
lemma wf⇩s⇩tI[intro]: "wfrestrictedvars⇩s⇩t S ⊆ V ⟹ wf⇩s⇩t V S"
proof (induction S)
case (Cons x S) thus ?case
proof (cases x)
case (Send t)
hence "wf⇩s⇩t V S" "V ∪ fv t = V" using Cons by auto
thus ?thesis using Send by simp
next
case (Equality a t t')
show ?thesis
proof (cases a)
case Assign
hence "wf⇩s⇩t V S" "fv t' ⊆ V" using Equality Cons by auto
thus ?thesis using wf_vars_mono Equality Assign by simp
next
case Check thus ?thesis using Equality Cons by auto
qed
qed simp_all
qed simp
lemma wf⇩s⇩tI'[intro]: "⋃(fv⇩r⇩c⇩v ` set S) ∪ ⋃(fv_r⇩e⇩q assign ` set S) ⊆ V ⟹ wf⇩s⇩t V S"
proof (induction S)
case (Cons x S) thus ?case
proof (cases x)
case (Equality a t t') thus ?thesis using Cons by (cases a) auto
qed simp_all
qed simp
lemma wf_append_exec: "wf⇩s⇩t V (S@S') ⟹ wf⇩s⇩t (V ∪ wfvarsoccs⇩s⇩t S) S'"
proof (induction S arbitrary: V)
case (Cons x S V) thus ?case
proof (cases x)
case (Send t)
hence "wf⇩s⇩t (V ∪ fv t ∪ wfvarsoccs⇩s⇩t S) S'" using Cons.prems Cons.IH by simp
thus ?thesis using Send by (auto simp add: sup_assoc)
next
case (Equality a t t') show ?thesis
proof (cases a)
case Assign
hence "wf⇩s⇩t (V ∪ fv t ∪ wfvarsoccs⇩s⇩t S) S'" using Equality Cons.prems Cons.IH by auto
thus ?thesis using Equality Assign by (auto simp add: sup_assoc)
next
case Check
hence "wf⇩s⇩t (V ∪ wfvarsoccs⇩s⇩t S) S'" using Equality Cons.prems Cons.IH by auto
thus ?thesis using Equality Check by (auto simp add: sup_assoc)
qed
qed auto
qed simp
lemma wf_append_suffix:
"wf⇩s⇩t V S ⟹ wfrestrictedvars⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩t S ∪ V ⟹ wf⇩s⇩t V (S@S')"
proof (induction V S rule: wf⇩s⇩t_induct)
case (ConsSnd V t S)
hence *: "wf⇩s⇩t (V ∪ fv t) S" by simp_all
hence "wfrestrictedvars⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩t S ∪ (V ∪ fv t)"
using ConsSnd.prems(2) by fastforce
thus ?case using ConsSnd.IH * by simp
next
case (ConsRcv V t S)
hence *: "fv t ⊆ V" "wf⇩s⇩t V S" by simp_all
hence "wfrestrictedvars⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩t S ∪ V"
using ConsRcv.prems(2) by fastforce
thus ?case using ConsRcv.IH * by simp
next
case (ConsEq V t t' S)
hence *: "fv t' ⊆ V" "wf⇩s⇩t (V ∪ fv t) S" by simp_all
moreover have "vars⇩s⇩t⇩p (Equality Assign t t') = fv t ∪ fv t'"
by simp
moreover have "wfrestrictedvars⇩s⇩t (Equality Assign t t'#S) = fv t ∪ fv t' ∪ wfrestrictedvars⇩s⇩t S"
by auto
ultimately have "wfrestrictedvars⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩t S ∪ (V ∪ fv t)"
using ConsEq.prems(2) by blast
thus ?case using ConsEq.IH * by simp
qed (simp_all add: wf⇩s⇩tI)
lemma wf_append_suffix':
assumes "wf⇩s⇩t V S"
and "⋃(fv⇩r⇩c⇩v ` set S') ∪ ⋃(fv_r⇩e⇩q assign ` set S') ⊆ wfvarsoccs⇩s⇩t S ∪ V"
shows "wf⇩s⇩t V (S@S')"
using assms
proof (induction V S rule: wf⇩s⇩t_induct)
case (ConsSnd V t S)
hence *: "wf⇩s⇩t (V ∪ fv t) S" by simp_all
have "wfvarsoccs⇩s⇩t (send⟨t⟩⇩s⇩t#S) = fv t ∪ wfvarsoccs⇩s⇩t S"
unfolding wfvarsoccs⇩s⇩t_def by simp
hence "(⋃a∈set S'. fv⇩r⇩c⇩v a) ∪ (⋃a∈set S'. fv_r⇩e⇩q assign a) ⊆ wfvarsoccs⇩s⇩t S ∪ (V ∪ fv t)"
using ConsSnd.prems(2) unfolding wfvarsoccs⇩s⇩t_def by auto
thus ?case using ConsSnd.IH[OF *] by auto
next
case (ConsEq V t t' S)
hence *: "fv t' ⊆ V" "wf⇩s⇩t (V ∪ fv t) S" by simp_all
have "wfvarsoccs⇩s⇩t (⟨assign: t ≐ t'⟩⇩s⇩t#S) = fv t ∪ wfvarsoccs⇩s⇩t S"
unfolding wfvarsoccs⇩s⇩t_def by simp
hence "(⋃a∈set S'. fv⇩r⇩c⇩v a) ∪ (⋃a∈set S'. fv_r⇩e⇩q assign a) ⊆ wfvarsoccs⇩s⇩t S ∪ (V ∪ fv t)"
using ConsEq.prems(2) unfolding wfvarsoccs⇩s⇩t_def by auto
thus ?case using ConsEq.IH[OF *(2)] *(1) by auto
qed (auto simp add: wf⇩s⇩tI')
lemma wf_send_compose: "wf⇩s⇩t V (S@(map Send X)@S') = wf⇩s⇩t V (S@Send (Fun f X)#S')"
proof (induction S arbitrary: V)
case Nil thus ?case
proof (induction X arbitrary: V)
case (Cons y Y) thus ?case by (simp add: sup_assoc)
qed simp
next
case (Cons s S) thus ?case
proof (cases s)
case (Equality ac t t') thus ?thesis using Cons by (cases ac) auto
qed auto
qed
lemma wf_snd_append[iff]: "wf⇩s⇩t V (S@[Send t]) = wf⇩s⇩t V S"
by (induct S rule: wf⇩s⇩t.induct) simp_all
lemma wf_snd_append': "wf⇩s⇩t V S ⟹ wf⇩s⇩t V (Send t#S)"
by simp
lemma wf_rcv_append[dest]: "wf⇩s⇩t V (S@Receive t#S') ⟹ wf⇩s⇩t V (S@S')"
by (induct S rule: wf⇩s⇩t.induct) simp_all
lemma wf_rcv_append'[intro]:
"⟦wf⇩s⇩t V (S@S'); fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V⟧ ⟹ wf⇩s⇩t V (S@Receive t#S')"
proof (induction S rule: wf⇩s⇩t_induct)
case (ConsRcv V t' S)
hence "wf⇩s⇩t V (S@S')" "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V"
by auto+
thus ?case using ConsRcv by auto
next
case (ConsEq V t' t'' S)
hence "fv t'' ⊆ V" by simp
moreover have
"wfrestrictedvars⇩s⇩t (Equality Assign t' t''#S) = fv t' ∪ fv t'' ∪ wfrestrictedvars⇩s⇩t S"
by auto
ultimately have "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ (V ∪ fv t')"
using ConsEq.prems(2) by blast
thus ?case using ConsEq by auto
qed auto
lemma wf_rcv_append''[intro]: "⟦wf⇩s⇩t V S; fv t ⊆ ⋃(set (map fv⇩s⇩n⇩d S))⟧ ⟹ wf⇩s⇩t V (S@[Receive t])"
by (induct S)
(simp, metis vars_snd_rcv_strand_subset2(1) append_Nil2 le_supI1 order_trans wf_rcv_append')
lemma wf_rcv_append'''[intro]: "⟦wf⇩s⇩t V S; fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V⟧ ⟹ wf⇩s⇩t V (S@[Receive t])"
by (simp add: wf_rcv_append'[of _ _ "[]"])
lemma wf_eq_append[dest]: "wf⇩s⇩t V (S@Equality a t t'#S') ⟹ fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V ⟹ wf⇩s⇩t V (S@S')"
proof (induction S rule: wf⇩s⇩t_induct)
case (Nil V)
hence "wf⇩s⇩t (V ∪ fv t) S'" by (cases a) auto
moreover have "V ∪ fv t = V" using Nil by auto
ultimately show ?case by simp
next
case (ConsRcv V u S)
hence "wf⇩s⇩t V (S @ Equality a t t' # S')" "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ V" "fv u ⊆ V"
by fastforce+
hence "wf⇩s⇩t V (S@S')" using ConsRcv.IH by auto
thus ?case using ‹fv u ⊆ V› by simp
next
case (ConsEq V u u' S)
hence "wf⇩s⇩t (V ∪ fv u) (S@Equality a t t'#S')" "fv t ⊆ wfrestrictedvars⇩s⇩t S ∪ (V ∪ fv u)" "fv u' ⊆ V"
by auto
hence "wf⇩s⇩t (V ∪ fv u) (S@S')" using ConsEq.IH by auto
thus ?case using ‹fv u' ⊆ V› by simp
qed auto
lemma wf_eq_append'[intro]:
"⟦wf⇩s⇩t V (S@S'); fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V⟧ ⟹ wf⇩s⇩t V (S@Equality a t t'#S')"
proof (induction S rule: wf⇩s⇩t_induct)
case Nil thus ?case by (cases a) auto
next
case (ConsEq V u u' S)
hence "wf⇩s⇩t (V ∪ fv u) (S@S')" "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V ∪ fv u"
by fastforce+
thus ?case using ConsEq by auto
next
case (ConsEq2 V u u' S)
hence "wf⇩s⇩t V (S@S')" by auto
thus ?case using ConsEq2 by auto
next
case (ConsRcv V u S)
hence "wf⇩s⇩t V (S@S')" "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V"
by fastforce+
thus ?case using ConsRcv by auto
next
case (ConsSnd V u S)
hence "wf⇩s⇩t (V ∪ fv u) (S@S')" "fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ (V ∪ fv u)"
by fastforce+
thus ?case using ConsSnd by auto
qed auto
lemma wf_eq_append''[intro]:
"⟦wf⇩s⇩t V (S@S'); fv t' ⊆ wfvarsoccs⇩s⇩t S ∪ V⟧ ⟹ wf⇩s⇩t V (S@[Equality a t t']@S')"
proof (induction S rule: wf⇩s⇩t_induct)
case Nil thus ?case by (cases a) auto
next
case (ConsEq V u u' S)
hence "wf⇩s⇩t (V ∪ fv u) (S@S')" "fv t' ⊆ wfvarsoccs⇩s⇩t S ∪ V ∪ fv u" by fastforce+
thus ?case using ConsEq by auto
next
case (ConsEq2 V u u' S)
hence "wf⇩s⇩t (V ∪ fv u) (S@S')" "fv t' ⊆ wfvarsoccs⇩s⇩t S ∪ V ∪ fv u" by fastforce+
thus ?case using ConsEq2 by auto
next
case (ConsRcv V u S)
hence "wf⇩s⇩t V (S@S')" "fv t' ⊆ wfvarsoccs⇩s⇩t S ∪ V" by fastforce+
thus ?case using ConsRcv by auto
next
case (ConsSnd V u S)
hence "wf⇩s⇩t (V ∪ fv u) (S@S')" "fv t' ⊆ wfvarsoccs⇩s⇩t S ∪ (V ∪ fv u)" by auto
thus ?case using ConsSnd by auto
qed auto
lemma wf_eq_append'''[intro]:
"⟦wf⇩s⇩t V S; fv t' ⊆ wfrestrictedvars⇩s⇩t S ∪ V⟧ ⟹ wf⇩s⇩t V (S@[Equality a t t'])"
by (simp add: wf_eq_append'[of _ _ "[]"])
lemma wf_eq_check_append[dest]: "wf⇩s⇩t V (S@Equality Check t t'#S') ⟹ wf⇩s⇩t V (S@S')"
by (induct S rule: wf⇩s⇩t.induct) simp_all
lemma wf_eq_check_append'[intro]: "wf⇩s⇩t V (S@S') ⟹ wf⇩s⇩t V (S@Equality Check t t'#S')"
by (induct S rule: wf⇩s⇩t.induct) auto
lemma wf_eq_check_append''[intro]: "wf⇩s⇩t V S ⟹ wf⇩s⇩t V (S@[Equality Check t t'])"
by (induct S rule: wf⇩s⇩t.induct) auto
lemma wf_ineq_append[dest]: "wf⇩s⇩t V (S@Inequality X F#S') ⟹ wf⇩s⇩t V (S@S')"
by (induct S rule: wf⇩s⇩t.induct) simp_all
lemma wf_ineq_append'[intro]: "wf⇩s⇩t V (S@S') ⟹ wf⇩s⇩t V (S@Inequality X F#S')"
by (induct S rule: wf⇩s⇩t.induct) auto
lemma wf_ineq_append''[intro]: "wf⇩s⇩t V S ⟹ wf⇩s⇩t V (S@[Inequality X F])"
by (induct S rule: wf⇩s⇩t.induct) auto
lemma wf_rcv_fv_single[elim]: "wf⇩s⇩t V (Receive t#S') ⟹ fv t ⊆ V"
by simp
lemma wf_rcv_fv: "wf⇩s⇩t V (S@Receive t#S') ⟹ fv t ⊆ wfvarsoccs⇩s⇩t S ∪ V"
by (induct S arbitrary: V) (auto split!: strand_step.split poscheckvariant.split)
lemma wf_eq_fv: "wf⇩s⇩t V (S@Equality Assign t t'#S') ⟹ fv t' ⊆ wfvarsoccs⇩s⇩t S ∪ V"
by (induct S arbitrary: V) (auto split!: strand_step.split poscheckvariant.split)
lemma wf_simple_fv_occurrence:
assumes "wf⇩s⇩t {} S" "simple S" "v ∈ wfrestrictedvars⇩s⇩t S"
shows "∃S⇩p⇩r⇩e S⇩s⇩u⇩f. S = S⇩p⇩r⇩e@Send (Var v)#S⇩s⇩u⇩f ∧ v ∉ wfrestrictedvars⇩s⇩t S⇩p⇩r⇩e"
using assms
proof (induction S rule: List.rev_induct)
case (snoc x S)
from ‹wf⇩s⇩t {} (S@[x])› have "wf⇩s⇩t {} S" "wf⇩s⇩t (wfrestrictedvars⇩s⇩t S) [x]"
using wf_append_exec[THEN wf_vars_mono, of "{}" S "[x]" "wfrestrictedvars⇩s⇩t S - wfvarsoccs⇩s⇩t S"]
vars_snd_rcv_strand_subset2(4)[of S]
Diff_partition[of "wfvarsoccs⇩s⇩t S" "wfrestrictedvars⇩s⇩t S"]
by auto
from ‹simple (S@[x])› have "simple S" "simple⇩s⇩t⇩p x" unfolding simple_def by auto
show ?case
proof (cases "v ∈ wfrestrictedvars⇩s⇩t S")
case False
show ?thesis
proof (cases x)
case (Receive t)
hence "fv t ⊆ wfrestrictedvars⇩s⇩t S" using ‹wf⇩s⇩t (wfrestrictedvars⇩s⇩t S) [x]› by simp
hence "v ∈ wfrestrictedvars⇩s⇩t S"
using ‹v ∈ wfrestrictedvars⇩s⇩t (S@[x])› ‹x = Receive t›
by auto
thus ?thesis using ‹x = Receive t› snoc.IH[OF ‹wf⇩s⇩t {} S› ‹simple S›] by fastforce
next
case (Send t)
hence "v ∈ vars⇩s⇩t⇩p x" using ‹v ∈ wfrestrictedvars⇩s⇩t (S@[x])› False by auto
from Send obtain w where "t = Var w" using ‹simple⇩s⇩t⇩p x› by (cases t) simp_all
hence "v = w" using ‹x = Send t› ‹v ∈ vars⇩s⇩t⇩p x› by simp
thus ?thesis using ‹x = Send t› ‹v ∉ wfrestrictedvars⇩s⇩t S› ‹t = Var w› by auto
next
case (Equality ac t t') thus ?thesis using snoc.prems(2) unfolding simple_def by auto
next
case (Inequality t t') thus ?thesis using False snoc.prems(3) by auto
qed
qed (use snoc.IH[OF ‹wf⇩s⇩t {} S› ‹simple S›] in fastforce)
qed simp
lemma Unifier_strand_fv_subset:
assumes g_in_ik: "t ∈ ik⇩s⇩t S"
and δ: "Unifier δ (Fun f X) t"
and disj: "bvars⇩s⇩t S ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "fv (Fun f X ⋅ δ) ⊆ ⋃(set (map fv⇩r⇩c⇩v (S ⋅⇩s⇩t δ)))"
by (metis (no_types) fv_subset_if_in_strand_ik[OF g_in_ik]
disj δ fv_strand_subst subst_apply_fv_subset)
lemma wf⇩s⇩t_induct'[consumes 1, case_names Nil ConsSnd ConsRcv ConsEq ConsEq2 ConsIneq]:
fixes S::"('a,'b) strand"
assumes "wf⇩s⇩t V S"
"P []"
"⋀t S. ⟦wf⇩s⇩t V S; P S⟧ ⟹ P (S@[Send t])"
"⋀t S. ⟦wf⇩s⇩t V S; P S; fv t ⊆ V ∪ wfvarsoccs⇩s⇩t S⟧ ⟹ P (S@[Receive t])"
"⋀t t' S. ⟦wf⇩s⇩t V S; P S; fv t' ⊆ V ∪ wfvarsoccs⇩s⇩t S⟧ ⟹ P (S@[Equality Assign t t'])"
"⋀t t' S. ⟦wf⇩s⇩t V S; P S⟧ ⟹ P (S@[Equality Check t t'])"
"⋀X F S. ⟦wf⇩s⇩t V S; P S⟧ ⟹ P (S@[Inequality X F])"
shows "P S"
using assms
proof (induction S rule: List.rev_induct)
case (snoc x S)
hence *: "wf⇩s⇩t V S" "wf⇩s⇩t (V ∪ wfvarsoccs⇩s⇩t S) [x]" by (metis wf_prefix, metis wf_append_exec)
have IH: "P S" using snoc.IH[OF *(1)] snoc.prems by auto
note ** = snoc.prems(3,4,5,6,7)[OF *(1) IH] *(2)
show ?case using **(1,2,4,5,6)
proof (cases x)
case (Equality ac t t')
then show ?thesis using **(3,4,6) by (cases ac) auto
qed auto
qed simp
lemma wf_subst_apply:
"wf⇩s⇩t V S ⟹ wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (S ⋅⇩s⇩t δ)"
proof (induction S arbitrary: V rule: wf⇩s⇩t_induct)
case (ConsRcv V t S)
hence "wf⇩s⇩t V S" "fv t ⊆ V" by simp_all
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (S ⋅⇩s⇩t δ)" "fv (t ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V)"
using ConsRcv.IH subst_apply_fv_subset by simp_all
thus ?case by simp
next
case (ConsSnd V t S)
hence "wf⇩s⇩t (V ∪ fv t) S" by simp
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` (V ∪ fv t))) (S ⋅⇩s⇩t δ)" using ConsSnd.IH by metis
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ)) (S ⋅⇩s⇩t δ)" using subst_apply_fv_union by metis
thus ?case by simp
next
case (ConsEq V t t' S)
hence "wf⇩s⇩t (V ∪ fv t) S" "fv t' ⊆ V" by auto
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` (V ∪ fv t))) (S ⋅⇩s⇩t δ)" and *: "fv (t' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V)"
using ConsEq.IH subst_apply_fv_subset by force+
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ)) (S ⋅⇩s⇩t δ)" using subst_apply_fv_union by metis
thus ?case using * by simp
qed simp_all
lemma wf_unify:
assumes wf: "wf⇩s⇩t V (S@Send (Fun f X)#S')"
and g_in_ik: "t ∈ ik⇩s⇩t S"
and δ: "Unifier δ (Fun f X) t"
and disj: "bvars⇩s⇩t (S@Send (Fun f X)#S') ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) ((S@S') ⋅⇩s⇩t δ)"
using assms
proof (induction S' arbitrary: V rule: List.rev_induct)
case (snoc x S' V)
have fun_fv_bound: "fv (Fun f X ⋅ δ) ⊆ ⋃(set (map fv⇩r⇩c⇩v (S ⋅⇩s⇩t δ)))"
using snoc.prems(4) bvars⇩s⇩t_split Unifier_strand_fv_subset[OF g_in_ik δ] by auto
hence "fv (Fun f X ⋅ δ) ⊆ fv⇩s⇩e⇩t (ik⇩s⇩t (S ⋅⇩s⇩t δ))" using fv_ik_is_fv_rcv by metis
hence "fv (Fun f X ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t (S ⋅⇩s⇩t δ)" using fv_ik_subset_fv_st[of "S ⋅⇩s⇩t δ"] by blast
hence *: "fv ((Fun f X) ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)" by fastforce
from snoc.prems(1) have "wf⇩s⇩t V (S@Send (Fun f X)#S')"
using wf_prefix[of V "S@Send (Fun f X)#S'" "[x]"] by simp
hence **: "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) ((S@S') ⋅⇩s⇩t δ)"
using snoc.IH[OF _ snoc.prems(2,3)] snoc.prems(4) by auto
from snoc.prems(1) have ***: "wf⇩s⇩t (V ∪ wfvarsoccs⇩s⇩t (S@Send (Fun f X)#S')) [x]"
using wf_append_exec[of V "(S@Send (Fun f X)#S')" "[x]"] by simp
from snoc.prems(4) have disj':
"bvars⇩s⇩t (S@S') ∩ (subst_domain δ ∪ range_vars δ) = {}"
"set (bvars⇩s⇩t⇩p x) ∩ (subst_domain δ ∪ range_vars δ) = {}"
by auto
show ?case
proof (cases x)
case (Send t)
thus ?thesis using wf_snd_append[of "fv⇩s⇩e⇩t (δ ` V)" "(S@S') ⋅⇩s⇩t δ"] ** by auto
next
case (Receive t)
hence "fv⇩s⇩t⇩p x ⊆ V ∪ wfvarsoccs⇩s⇩t (S@Send (Fun f X)#S')" using *** by auto
hence "fv⇩s⇩t⇩p x ⊆ V ∪ wfrestrictedvars⇩s⇩t (S@Send (Fun f X)#S')"
using vars_snd_rcv_strand_subset2(4)[of "S@Send (Fun f X)#S'"] by blast
hence "fv⇩s⇩t⇩p x ⊆ V ∪ fv (Fun f X) ∪ wfrestrictedvars⇩s⇩t (S@S')" by auto
hence "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ fv ((Fun f X) ⋅ δ) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
by (metis (no_types) inf_sup_aci(5) subst_apply_fv_subset_strand2 subst_apply_fv_union disj')
hence "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)" using * by blast
hence "fv (t ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V) " using ‹x = Receive t› by auto
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (((S@S') ⋅⇩s⇩t δ)@[Receive (t ⋅ δ)])"
using wf_rcv_append'''[OF **, of "t ⋅ δ"] by metis
thus ?thesis using ‹x = Receive t› by auto
next
case (Equality ac s s') show ?thesis
proof (cases ac)
case Assign
hence "fv s' ⊆ V ∪ wfvarsoccs⇩s⇩t (S@Send (Fun f X)#S')" using Equality *** by auto
hence "fv s' ⊆ V ∪ wfrestrictedvars⇩s⇩t (S@Send (Fun f X)#S')"
using vars_snd_rcv_strand_subset2(4)[of "S@Send (Fun f X)#S'"] by blast
hence "fv s' ⊆ V ∪ fv (Fun f X) ∪ wfrestrictedvars⇩s⇩t (S@S')" by auto
moreover have "fv s' = fv_r⇩e⇩q ac x" "fv (s' ⋅ δ) = fv_r⇩e⇩q ac (x ⋅⇩s⇩t⇩p δ)"
using Equality by simp_all
ultimately have "fv (s' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ fv (Fun f X ⋅ δ) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
using subst_apply_fv_subset_strand2[of "fv⇩e⇩q ac" ac x]
by (metis disj'(1) subst_apply_fv_subset_strand_trm2 subst_apply_fv_union sup_commute)
hence "fv (s' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)" using * by blast
hence "fv (s' ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using ‹x = Equality ac s s'› by auto
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (((S@S') ⋅⇩s⇩t δ)@[Equality ac (s ⋅ δ) (s' ⋅ δ)])"
using wf_eq_append'''[OF **] by metis
thus ?thesis using ‹x = Equality ac s s'› by auto
next
case Check thus ?thesis using wf_eq_check_append''[OF **] Equality by simp
qed
next
case (Inequality t t') thus ?thesis using wf_ineq_append''[OF **] by simp
qed
qed (auto dest: wf_subst_apply)
lemma wf_equality:
assumes wf: "wf⇩s⇩t V (S@Equality ac t t'#S')"
and δ: "mgu t t' = Some δ"
and disj: "bvars⇩s⇩t (S@Equality ac t t'#S') ∩ (subst_domain δ ∪ range_vars δ) = {}"
shows "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) ((S@S') ⋅⇩s⇩t δ)"
using assms
proof (induction S' arbitrary: V rule: List.rev_induct)
case Nil thus ?case using wf_prefix[of V S "[Equality ac t t']"] wf_subst_apply[of V S δ] by auto
next
case (snoc x S' V) show ?case
proof (cases ac)
case Assign
hence "fv t' ⊆ V ∪ wfvarsoccs⇩s⇩t S"
using wf_eq_fv[of V, of S t t' "S'@[x]"] snoc by auto
hence "fv t' ⊆ V ∪ wfrestrictedvars⇩s⇩t S"
using vars_snd_rcv_strand_subset2(4)[of S] by blast
hence "fv t' ⊆ V ∪ wfrestrictedvars⇩s⇩t (S@S')" by force
moreover have disj':
"bvars⇩s⇩t (S@S') ∩ (subst_domain δ ∪ range_vars δ) = {}"
"set (bvars⇩s⇩t⇩p x) ∩ (subst_domain δ ∪ range_vars δ) = {}"
"bvars⇩s⇩t (S@Equality ac t t'#S') ∩ (subst_domain δ ∪ range_vars δ) = {}"
using snoc.prems(3) by auto
ultimately have
"fv (t' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
by (metis inf_sup_aci(5) subst_apply_fv_subset_strand_trm2)
moreover have "fv (t ⋅ δ) = fv (t' ⋅ δ)"
by (metis MGU_is_Unifier[OF mgu_gives_MGU[OF δ]])
ultimately have *:
"fv (t ⋅ δ) ∪ fv (t' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
by simp
from snoc.prems(1) have "wf⇩s⇩t V (S@Equality ac t t'#S')"
using wf_prefix[of V "S@Equality ac t t'#S'"] by simp
hence **: "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) ((S@S') ⋅⇩s⇩t δ)" by (metis snoc.IH δ disj'(3))
from snoc.prems(1) have ***: "wf⇩s⇩t (V ∪ wfvarsoccs⇩s⇩t (S@Equality ac t t'#S')) [x]"
using wf_append_exec[of V "(S@Equality ac t t'#S')" "[x]"] by simp
show ?thesis
proof (cases x)
case (Send t)
thus ?thesis using wf_snd_append[of "fv⇩s⇩e⇩t (δ ` V)" "(S@S') ⋅⇩s⇩t δ"] ** by auto
next
case (Receive s)
hence "fv⇩s⇩t⇩p x ⊆ V ∪ wfvarsoccs⇩s⇩t (S@Equality ac t t'#S')" using *** by auto
hence "fv⇩s⇩t⇩p x ⊆ V ∪ wfrestrictedvars⇩s⇩t (S@Equality ac t t'#S')"
using vars_snd_rcv_strand_subset2(4)[of "S@Equality ac t t'#S'"] by blast
hence "fv⇩s⇩t⇩p x ⊆ V ∪ fv t ∪ fv t' ∪ wfrestrictedvars⇩s⇩t (S@S')"
by (cases ac) auto
hence "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ) ∪ fv (t' ⋅ δ) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
using subst_apply_fv_subset_strand2[of fv⇩s⇩t⇩p]
by (metis (no_types) inf_sup_aci(5) subst_apply_fv_union disj'(1,2))
hence "fv⇩s⇩t⇩p (x ⋅⇩s⇩t⇩p δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
when "ac = Assign"
using * that by blast
hence "fv (s ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ∪ (fv⇩s⇩e⇩t (δ ` V))"
when "ac = Assign"
using ‹x = Receive s› that by auto
hence "wf⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (((S@S') ⋅⇩s⇩t δ)@[Receive (s ⋅ δ)])"
when "ac = Assign"
using wf_rcv_append'''[OF **, of "s ⋅ δ"] that by metis
thus ?thesis using ‹x = Receive s› Assign by auto
next
case (Equality ac' s s') show ?thesis
proof (cases ac')
case Assign
hence "fv s' ⊆ V ∪ wfvarsoccs⇩s⇩t (S@Equality ac t t'#S')" using *** Equality by auto
hence "fv s' ⊆ V ∪ wfrestrictedvars⇩s⇩t (S@Equality ac t t'#S')"
using vars_snd_rcv_strand_subset2(4)[of "S@Equality ac t t'#S'"] by blast
hence "fv s' ⊆ V ∪ fv t ∪ fv t' ∪ wfrestrictedvars⇩s⇩t (S@S')"
by (cases ac) auto
moreover have "fv s' = fv_r⇩e⇩q ac' x" "fv (s' ⋅ δ) = fv_r⇩e⇩q ac' (x ⋅⇩s⇩t⇩p δ)"
using Equality by simp_all
ultimately have
"fv (s' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ) ∪ fv (t' ⋅ δ) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
using subst_apply_fv_subset_strand2[of "fv_r⇩e⇩q ac'" ac' x]
by (metis disj'(1) subst_apply_fv_subset_strand_trm2 subst_apply_fv_union sup_commute)
hence "fv (s' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V) ∪ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ)"
using * ‹ac = Assign› by blast
hence ****:
"fv (s' ⋅ δ) ⊆ wfrestrictedvars⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ∪ fv⇩s⇩e⇩t (δ ` V)"
using ‹x = Equality ac' s s'› ‹ac = Assign› by auto
thus ?thesis
using ‹x = Equality ac' s s'› ** **** wf_eq_append' ‹ac = Assign›
by (metis (no_types, lifting) append.assoc append_Nil2 strand_step.case(3)
strand_subst_hom subst_apply_strand_step_def)
next
case Check thus ?thesis using wf_eq_check_append''[OF **] Equality by simp
qed
next
case (Inequality s s') thus ?thesis using wf_ineq_append''[OF **] by simp
qed
qed (metis snoc.prems(1) wf_eq_check_append wf_subst_apply)
qed
lemma wf_rcv_prefix_ground:
"wf⇩s⇩t {} ((map Receive M)@S) ⟹ vars⇩s⇩t (map Receive M) = {}"
by (induct M) auto
lemma simple_wfvarsoccs⇩s⇩t_is_fv⇩s⇩n⇩d:
assumes "simple S"
shows "wfvarsoccs⇩s⇩t S = ⋃(set (map fv⇩s⇩n⇩d S))"
using assms unfolding simple_def
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
lemma wf⇩s⇩t_simple_induct[consumes 2, case_names Nil ConsSnd ConsRcv ConsIneq]:
fixes S::"('a,'b) strand"
assumes "wf⇩s⇩t V S" "simple S"
"P []"
"⋀v S. ⟦wf⇩s⇩t V S; simple S; P S⟧ ⟹ P (S@[Send (Var v)])"
"⋀t S. ⟦wf⇩s⇩t V S; simple S; P S; fv t ⊆ V ∪ ⋃(set (map fv⇩s⇩n⇩d S))⟧ ⟹ P (S@[Receive t])"
"⋀X F S. ⟦wf⇩s⇩t V S; simple S; P S⟧ ⟹ P (S@[Inequality X F])"
shows "P S"
using assms
proof (induction S rule: wf⇩s⇩t_induct')
case (ConsSnd t S)
hence "P S" by auto
obtain v where "t = Var v" using simple_snd_is_var[OF _ ‹simple (S@[Send t])›] by auto
thus ?case using ConsSnd.prems(3)[OF ‹wf⇩s⇩t V S› _ ‹P S›] ‹simple (S@[Send t])› by auto
next
case (ConsRcv t S) thus ?case using simple_wfvarsoccs⇩s⇩t_is_fv⇩s⇩n⇩d[of "S@[Receive t]"] by auto
qed (auto simp add: simple_def)
lemma wf_trm_stp_dom_fv_disjoint:
"⟦wf⇩c⇩o⇩n⇩s⇩t⇩r S θ; t ∈ trms⇩s⇩t S⟧ ⟹ subst_domain θ ∩ fv t = {}"
unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def by force
lemma wf_constr_bvars_disj: "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ ⟹ (subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t S = {}"
unfolding range_vars_alt_def wf⇩c⇩o⇩n⇩s⇩t⇩r_def by fastforce
lemma wf_constr_bvars_disj':
assumes "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t S"
shows "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}" (is ?A)
and "(subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t (S ⋅⇩s⇩t δ) = {}" (is ?B)
proof -
have "(subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t S = {}" "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}"
using assms(1) unfolding range_vars_alt_def wf⇩c⇩o⇩n⇩s⇩t⇩r_def by fastforce+
thus ?A and ?B using assms(2) bvars_subst_ident[of S δ] by blast+
qed
lemma (in intruder_model) wf_simple_strand_first_Send_var_split:
assumes "wf⇩s⇩t {} S" "simple S" "∃v ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ = ℐ v"
shows "∃v S⇩p⇩r⇩e S⇩s⇩u⇩f. S = S⇩p⇩r⇩e@Send (Var v)#S⇩s⇩u⇩f ∧ t ⋅ ℐ = ℐ v
∧ ¬(∃w ∈ wfrestrictedvars⇩s⇩t S⇩p⇩r⇩e. t ⋅ ℐ = ℐ w)"
(is "?P S")
using assms
proof (induction S rule: wf⇩s⇩t_simple_induct)
case (ConsSnd v S) show ?case
proof (cases "∃w ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ = ℐ w")
case True thus ?thesis using ConsSnd.IH by fastforce
next
case False thus ?thesis using ConsSnd.prems by auto
qed
next
case (ConsRcv t' S)
have "fv t' ⊆ wfrestrictedvars⇩s⇩t S" using ConsRcv.hyps(3) vars_snd_rcv_strand_subset2(1) by force
hence "∃v ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ = ℐ v"
using ConsRcv.prems(1) by fastforce
hence "?P S" by (metis ConsRcv.IH)
thus ?case by fastforce
next
case (ConsIneq X F S)
moreover have "wfrestrictedvars⇩s⇩t (S @ [Inequality X F]) = wfrestrictedvars⇩s⇩t S" by auto
ultimately have "?P S" by blast
thus ?case by fastforce
qed simp
lemma (in intruder_model) wf_strand_first_Send_var_split:
assumes "wf⇩s⇩t {} S" "∃v ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ ⊑ ℐ v"
shows "∃S⇩p⇩r⇩e S⇩s⇩u⇩f. ¬(∃w ∈ wfrestrictedvars⇩s⇩t S⇩p⇩r⇩e. t ⋅ ℐ ⊑ ℐ w)
∧ ((∃t'. S = S⇩p⇩r⇩e@Send t'#S⇩s⇩u⇩f ∧ t ⋅ ℐ ⊑ t' ⋅ ℐ)
∨ (∃t' t''. S = S⇩p⇩r⇩e@Equality Assign t' t''#S⇩s⇩u⇩f ∧ t ⋅ ℐ ⊑ t' ⋅ ℐ))"
(is "∃S⇩p⇩r⇩e S⇩s⇩u⇩f. ?P S⇩p⇩r⇩e ∧ ?Q S S⇩p⇩r⇩e S⇩s⇩u⇩f")
using assms
proof (induction S rule: wf⇩s⇩t_induct')
case (ConsSnd t' S) show ?case
proof (cases "∃w ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ ⊑ ℐ w")
case True
then obtain S⇩p⇩r⇩e S⇩s⇩u⇩f where "?P S⇩p⇩r⇩e" "?Q S S⇩p⇩r⇩e S⇩s⇩u⇩f"
using ConsSnd.IH by moura
thus ?thesis by fastforce
next
case False
then obtain v where v: "v ∈ fv t'" "t ⋅ ℐ ⊑ ℐ v"
using ConsSnd.prems by auto
hence "t ⋅ ℐ ⊑ t' ⋅ ℐ"
using subst_mono[of "Var v" t' ℐ] vars_iff_subtermeq[of v t'] term.order_trans
by auto
thus ?thesis using False v by auto
qed
next
case (ConsRcv t' S)
have "fv t' ⊆ wfrestrictedvars⇩s⇩t S"
using ConsRcv.hyps vars_snd_rcv_strand_subset2(4)[of S] by blast
hence "∃v ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ ⊑ ℐ v"
using ConsRcv.prems by fastforce
then obtain S⇩p⇩r⇩e S⇩s⇩u⇩f where "?P S⇩p⇩r⇩e" "?Q S S⇩p⇩r⇩e S⇩s⇩u⇩f"
using ConsRcv.IH by moura
thus ?case by fastforce
next
case (ConsEq s s' S)
have *: "fv s' ⊆ wfrestrictedvars⇩s⇩t S"
using ConsEq.hyps vars_snd_rcv_strand_subset2(4)[of S]
by blast
show ?case
proof (cases "∃v ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ ⊑ ℐ v")
case True
then obtain S⇩p⇩r⇩e S⇩s⇩u⇩f where "?P S⇩p⇩r⇩e" "?Q S S⇩p⇩r⇩e S⇩s⇩u⇩f"
using ConsEq.IH by moura
thus ?thesis by fastforce
next
case False
then obtain v where "v ∈ fv s" "t ⋅ ℐ ⊑ ℐ v" using ConsEq.prems * by auto
hence "t ⋅ ℐ ⊑ s ⋅ ℐ"
using vars_iff_subtermeq[of v s] subst_mono[of "Var v" s ℐ] term.order_trans
by auto
thus ?thesis using False by fastforce
qed
next
case (ConsEq2 s s' S)
have "wfrestrictedvars⇩s⇩t (S@[Equality Check s s']) = wfrestrictedvars⇩s⇩t S" by auto
hence "∃v ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ ⊑ ℐ v" using ConsEq2.prems by metis
then obtain S⇩p⇩r⇩e S⇩s⇩u⇩f where "?P S⇩p⇩r⇩e" "?Q S S⇩p⇩r⇩e S⇩s⇩u⇩f"
using ConsEq2.IH by moura
thus ?case by fastforce
next
case (ConsIneq X F S)
hence "∃v ∈ wfrestrictedvars⇩s⇩t S. t ⋅ ℐ ⊑ ℐ v" by fastforce
then obtain S⇩p⇩r⇩e S⇩s⇩u⇩f where "?P S⇩p⇩r⇩e" "?Q S S⇩p⇩r⇩e S⇩s⇩u⇩f"
using ConsIneq.IH by moura
thus ?case by fastforce
qed simp
subsection ‹Constraint Semantics›
context intruder_model
begin
subsubsection ‹Definitions›
text ‹The constraint semantics in which the intruder is limited to composition only›
fun strand_sem_c::"('fun,'var) terms ⇒ ('fun,'var) strand ⇒ ('fun,'var) subst ⇒ bool" ("⟦_; _⟧⇩c")
where
"⟦M; []⟧⇩c = (λℐ. True)"
| "⟦M; Send t#S⟧⇩c = (λℐ. M ⊢⇩c t ⋅ ℐ ∧ ⟦M; S⟧⇩c ℐ)"
| "⟦M; Receive t#S⟧⇩c = (λℐ. ⟦insert (t ⋅ ℐ) M; S⟧⇩c ℐ)"
| "⟦M; Equality _ t t'#S⟧⇩c = (λℐ. t ⋅ ℐ = t' ⋅ ℐ ∧ ⟦M; S⟧⇩c ℐ)"
| "⟦M; Inequality X F#S⟧⇩c = (λℐ. ineq_model ℐ X F ∧ ⟦M; S⟧⇩c ℐ)"
definition constr_sem_c ("_ ⊨⇩c ⟨_,_⟩") where "ℐ ⊨⇩c ⟨S,θ⟩ ≡ (θ supports ℐ ∧ ⟦{}; S⟧⇩c ℐ)"
abbreviation constr_sem_c' ("_ ⊨⇩c ⟨_⟩" 90) where "ℐ ⊨⇩c ⟨S⟩ ≡ ℐ ⊨⇩c ⟨S,Var⟩"
text ‹The full constraint semantics›
fun strand_sem_d::"('fun,'var) terms ⇒ ('fun,'var) strand ⇒ ('fun,'var) subst ⇒ bool" ("⟦_; _⟧⇩d")
where
"⟦M; []⟧⇩d = (λℐ. True)"
| "⟦M; Send t#S⟧⇩d = (λℐ. M ⊢ t ⋅ ℐ ∧ ⟦M; S⟧⇩d ℐ)"
| "⟦M; Receive t#S⟧⇩d = (λℐ. ⟦insert (t ⋅ ℐ) M; S⟧⇩d ℐ)"
| "⟦M; Equality _ t t'#S⟧⇩d = (λℐ. t ⋅ ℐ = t' ⋅ ℐ ∧ ⟦M; S⟧⇩d ℐ)"
| "⟦M; Inequality X F#S⟧⇩d = (λℐ. ineq_model ℐ X F ∧ ⟦M; S⟧⇩d ℐ)"
definition constr_sem_d ("_ ⊨ ⟨_,_⟩") where "ℐ ⊨ ⟨S,θ⟩ ≡ (θ supports ℐ ∧ ⟦{}; S⟧⇩d ℐ)"
abbreviation constr_sem_d' ("_ ⊨ ⟨_⟩" 90) where "ℐ ⊨ ⟨S⟩ ≡ ℐ ⊨ ⟨S,Var⟩"
lemmas strand_sem_induct = strand_sem_c.induct[case_names Nil ConsSnd ConsRcv ConsEq ConsIneq]
subsubsection ‹Lemmata›
lemma strand_sem_d_if_c: "ℐ ⊨⇩c ⟨S,θ⟩ ⟹ ℐ ⊨ ⟨S,θ⟩"
proof -
assume *: "ℐ ⊨⇩c ⟨S,θ⟩"
{ fix M have "⟦M; S⟧⇩c ℐ ⟹ ⟦M; S⟧⇩d ℐ"
proof (induction S rule: strand_sem_induct)
case (ConsSnd M t S)
hence "M ⊢⇩c t ⋅ ℐ" "⟦M; S⟧⇩d ℐ" by auto
thus ?case using strand_sem_d.simps(2)[of M t S] by auto
qed (auto simp add: ineq_model_def)
}
thus ?thesis using * by (simp add: constr_sem_c_def constr_sem_d_def)
qed
lemma strand_sem_mono_ik:
"⟦M ⊆ M'; ⟦M; S⟧⇩c θ⟧ ⟹ ⟦M'; S⟧⇩c θ" (is "⟦?A'; ?A''⟧ ⟹ ?A")
"⟦M ⊆ M'; ⟦M; S⟧⇩d θ⟧ ⟹ ⟦M'; S⟧⇩d θ" (is "⟦?B'; ?B''⟧ ⟹ ?B")
proof -
show "⟦?A'; ?A''⟧ ⟹ ?A"
proof (induction M S arbitrary: M M' rule: strand_sem_induct)
case (ConsRcv M t S)
thus ?case using ConsRcv.IH[of "insert (t ⋅ θ) M" "insert (t ⋅ θ) M'"] by auto
next
case (ConsSnd M t S)
hence "M ⊢⇩c t ⋅ θ" "⟦M'; S⟧⇩c θ" by auto
hence "M' ⊢⇩c t ⋅ θ" using ideduct_synth_mono ‹M ⊆ M'› by metis
thus ?case using ‹⟦M'; S⟧⇩c θ› by simp
qed auto
show "⟦?B'; ?B''⟧ ⟹ ?B"
proof (induction M S arbitrary: M M' rule: strand_sem_induct)
case (ConsRcv M t S)
thus ?case using ConsRcv.IH[of "insert (t ⋅ θ) M" "insert (t ⋅ θ) M'"] by auto
next
case (ConsSnd M t S)
hence "M ⊢ t ⋅ θ" "⟦M'; S⟧⇩d θ" by auto
hence "M' ⊢ t ⋅ θ" using ideduct_mono ‹M ⊆ M'› by metis
thus ?case using ‹⟦M'; S⟧⇩d θ› by simp
qed auto
qed
context
begin
private lemma strand_sem_split_left:
"⟦M; S@S'⟧⇩c θ ⟹ ⟦M; S⟧⇩c θ"
"⟦M; S@S'⟧⇩d θ ⟹ ⟦M; S⟧⇩d θ"
proof (induct S arbitrary: M)
case (Cons x S)
{ case 1 thus ?case using Cons by (cases x) simp_all }
{ case 2 thus ?case using Cons by (cases x) simp_all }
qed simp_all
private lemma strand_sem_split_right:
"⟦M; S@S'⟧⇩c θ ⟹ ⟦M ∪ (ik⇩s⇩t S ⋅⇩s⇩e⇩t θ); S'⟧⇩c θ"
"⟦M; S@S'⟧⇩d θ ⟹ ⟦M ∪ (ik⇩s⇩t S ⋅⇩s⇩e⇩t θ); S'⟧⇩d θ"
proof (induction S arbitrary: M rule: ik⇩s⇩t_induct)
case (ConsRcv t S)
{ case 1 thus ?case using ConsRcv.IH[of "insert (t ⋅ θ) M"] by simp }
{ case 2 thus ?case using ConsRcv.IH[of "insert (t ⋅ θ) M"] by simp }
qed simp_all
lemmas strand_sem_split[dest] =
strand_sem_split_left(1) strand_sem_split_right(1)
strand_sem_split_left(2) strand_sem_split_right(2)
end
lemma strand_sem_Send_split[dest]:
"⟦⟦M; map Send T⟧⇩c θ; t ∈ set T⟧ ⟹ ⟦M; [Send t]⟧⇩c θ" (is "⟦?A'; ?A''⟧ ⟹ ?A")
"⟦⟦M; map Send T⟧⇩d θ; t ∈ set T⟧ ⟹ ⟦M; [Send t]⟧⇩d θ" (is "⟦?B'; ?B''⟧ ⟹ ?B")
"⟦⟦M; map Send T@S⟧⇩c θ; t ∈ set T⟧ ⟹ ⟦M; Send t#S⟧⇩c θ" (is "⟦?C'; ?C''⟧ ⟹ ?C")
"⟦⟦M; map Send T@S⟧⇩d θ; t ∈ set T⟧ ⟹ ⟦M; Send t#S⟧⇩d θ" (is "⟦?D'; ?D''⟧ ⟹ ?D")
proof -
show A: "⟦?A'; ?A''⟧ ⟹ ?A" by (induct "map Send T" arbitrary: T rule: strand_sem_c.induct) auto
show B: "⟦?B'; ?B''⟧ ⟹ ?B" by (induct "map Send T" arbitrary: T rule: strand_sem_d.induct) auto
show "⟦?C'; ?C''⟧ ⟹ ?C" "⟦?D'; ?D''⟧ ⟹ ?D"
using list.set_map list.simps(8) set_empty ik_snd_empty sup_bot.right_neutral
by (metis (no_types, lifting) A strand_sem_split(1,2) strand_sem_c.simps(2),
metis (no_types, lifting) B strand_sem_split(3,4) strand_sem_d.simps(2))
qed
lemma strand_sem_Send_map:
"(⋀t. t ∈ set T ⟹ ⟦M; [Send t]⟧⇩c ℐ) ⟹ ⟦M; map Send T⟧⇩c ℐ"
"(⋀t. t ∈ set T ⟹ ⟦M; [Send t]⟧⇩d ℐ) ⟹ ⟦M; map Send T⟧⇩d ℐ"
by (induct T) auto
lemma strand_sem_Receive_map: "⟦M; map Receive T⟧⇩c ℐ" "⟦M; map Receive T⟧⇩d ℐ"
by (induct T arbitrary: M) auto
lemma strand_sem_append[intro]:
"⟦⟦M; S⟧⇩c θ; ⟦M ∪ (ik⇩s⇩t S ⋅⇩s⇩e⇩t θ); S'⟧⇩c θ⟧ ⟹ ⟦M; S@S'⟧⇩c θ"
"⟦⟦M; S⟧⇩d θ; ⟦M ∪ (ik⇩s⇩t S ⋅⇩s⇩e⇩t θ); S'⟧⇩d θ⟧ ⟹ ⟦M; S@S'⟧⇩d θ"
proof (induction S arbitrary: M)
case (Cons x S)
{ case 1 thus ?case using Cons by (cases x) auto }
{ case 2 thus ?case using Cons by (cases x) auto }
qed simp_all
lemma ineq_model_subst:
fixes F::"(('a,'b) term × ('a,'b) term) list"
assumes "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
and "ineq_model (δ ∘⇩s θ) X F"
shows "ineq_model θ X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
proof -
{ fix σ::"('a,'b) subst" and t t'
assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
and *: "list_ex (λf. fst f ⋅ (σ ∘⇩s (δ ∘⇩s θ)) ≠ snd f ⋅ (σ ∘⇩s (δ ∘⇩s θ))) F"
obtain f where f: "f ∈ set F" "fst f ⋅ σ ∘⇩s (δ ∘⇩s θ) ≠ snd f ⋅ σ ∘⇩s (δ ∘⇩s θ)"
using * by (induct F) auto
have "σ ∘⇩s (δ ∘⇩s θ) = δ ∘⇩s (σ ∘⇩s θ)"
by (metis (no_types, lifting) σ subst_compose_assoc assms(1) inf_sup_aci(1)
subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def)
hence "(fst f ⋅ δ) ⋅ σ ∘⇩s θ ≠ (snd f ⋅ δ) ⋅ σ ∘⇩s θ" using f by auto
moreover have "(fst f ⋅ δ, snd f ⋅ δ) ∈ set (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using f(1) by (auto simp add: subst_apply_pairs_def)
ultimately have "list_ex (λf. fst f ⋅ (σ ∘⇩s θ) ≠ snd f ⋅ (σ ∘⇩s θ)) (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using f(1) Bex_set by fastforce
}
thus ?thesis using assms unfolding ineq_model_def by simp
qed
lemma ineq_model_subst':
fixes F::"(('a,'b) term × ('a,'b) term) list"
assumes "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
and "ineq_model θ X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
shows "ineq_model (δ ∘⇩s θ) X F"
proof -
{ fix σ::"('a,'b) subst" and t t'
assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
and *: "list_ex (λf. fst f ⋅ (σ ∘⇩s θ) ≠ snd f ⋅ (σ ∘⇩s θ)) (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
obtain f where f: "f ∈ set (F ⋅⇩p⇩a⇩i⇩r⇩s δ)" "fst f ⋅ σ ∘⇩s θ ≠ snd f ⋅ σ ∘⇩s θ"
using * by (induct F) (auto simp add: subst_apply_pairs_def)
then obtain g where g: "g ∈ set F" "f = g ⋅⇩p δ" by (auto simp add: subst_apply_pairs_def)
have "σ ∘⇩s (δ ∘⇩s θ) = δ ∘⇩s (σ ∘⇩s θ)"
by (metis (no_types, lifting) σ subst_compose_assoc assms(1) inf_sup_aci(1)
subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def)
hence "fst g ⋅ σ ∘⇩s (δ ∘⇩s θ) ≠ snd g ⋅ σ ∘⇩s (δ ∘⇩s θ)"
using f(2) g by (simp add: prod.case_eq_if)
hence "list_ex (λf. fst f ⋅ (σ ∘⇩s (δ ∘⇩s θ)) ≠ snd f ⋅ (σ ∘⇩s (δ ∘⇩s θ))) F"
using g Bex_set by fastforce
}
thus ?thesis using assms unfolding ineq_model_def by simp
qed
lemma ineq_model_ground_subst:
fixes F::"(('a,'b) term × ('a,'b) term) list"
assumes "fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ subst_domain δ"
and "ground (subst_range δ)"
and "ineq_model δ X F"
shows "ineq_model (δ ∘⇩s θ) X F"
proof -
{ fix σ::"('a,'b) subst" and t t'
assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
and *: "list_ex (λf. fst f ⋅ (σ ∘⇩s δ) ≠ snd f ⋅ (σ ∘⇩s δ )) F"
obtain f where f: "f ∈ set F" "fst f ⋅ σ ∘⇩s δ ≠ snd f ⋅ σ ∘⇩s δ"
using * by (induct F) auto
hence "fv (fst f) ⊆ fv⇩p⇩a⇩i⇩r⇩s F" "fv (snd f) ⊆ fv⇩p⇩a⇩i⇩r⇩s F" by auto
hence "fv (fst f) - set X ⊆ subst_domain δ" "fv (snd f) - set X ⊆ subst_domain δ"
using assms(1) by auto
hence "fv (fst f ⋅ σ) ⊆ subst_domain δ" "fv (snd f ⋅ σ) ⊆ subst_domain δ"
using σ by (simp_all add: range_vars_alt_def subst_fv_unfold_ground_img)
hence "fv (fst f ⋅ σ ∘⇩s δ) = {}" "fv (snd f ⋅ σ ∘⇩s δ) = {}"
using assms(2) by (simp_all add: subst_fv_dom_ground_if_ground_img)
hence "fst f ⋅ σ ∘⇩s (δ ∘⇩s θ) ≠ snd f ⋅ σ ∘⇩s (δ ∘⇩s θ)" using f(2) subst_ground_ident by fastforce
hence "list_ex (λf. fst f ⋅ (σ ∘⇩s (δ ∘⇩s θ)) ≠ snd f ⋅ (σ ∘⇩s (δ ∘⇩s θ))) F"
using f(1) Bex_set by fastforce
}
thus ?thesis using assms unfolding ineq_model_def by simp
qed
context
begin
private lemma strand_sem_subst_c:
assumes "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "⟦M; S⟧⇩c (δ ∘⇩s θ) ⟹ ⟦M; S ⋅⇩s⇩t δ⟧⇩c θ"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
case (ConsSnd M t S)
hence "⟦M; S ⋅⇩s⇩t δ⟧⇩c θ" "M ⊢⇩c t ⋅ (δ ∘⇩s θ)" by auto
hence "M ⊢⇩c (t ⋅ δ) ⋅ θ"
using subst_comp_all[of δ θ M] subst_subst_compose[of t δ θ] by simp
thus ?case
using ‹⟦M; S ⋅⇩s⇩t δ⟧⇩c θ›
unfolding subst_apply_strand_def
by simp
next
case (ConsRcv M t S)
have *: "⟦insert (t ⋅ δ ∘⇩s θ) M; S⟧⇩c (δ ∘⇩s θ)" using ConsRcv.prems(1) by simp
have "bvars⇩s⇩t (Receive t#S) = bvars⇩s⇩t S" by auto
hence **: "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}" using ConsRcv.prems(2) by blast
have "⟦M; Receive (t ⋅ δ)#(S ⋅⇩s⇩t δ)⟧⇩c θ"
using ConsRcv.IH[OF * **] by (simp add: subst_all_insert)
thus ?case by simp
next
case (ConsIneq M X F S)
hence *: "⟦M; S ⋅⇩s⇩t δ⟧⇩c θ" and
***: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
unfolding bvars⇩s⇩t_def ineq_model_def by auto
have **: "ineq_model (δ ∘⇩s θ) X F"
using ConsIneq by (auto simp add: subst_compose_assoc ineq_model_def)
have "∀γ. subst_domain γ = set X ∧ ground (subst_range γ)
⟶ (subst_domain δ ∪ range_vars δ) ∩ (subst_domain γ ∪ range_vars γ) = {}"
using * ** *** unfolding range_vars_alt_def by auto
hence "∀γ. subst_domain γ = set X ∧ ground (subst_range γ) ⟶ γ ∘⇩s δ = δ ∘⇩s γ"
by (metis subst_comp_eq_if_disjoint_vars)
hence "ineq_model θ X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using ineq_model_subst[OF *** **]
by blast
moreover have "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
ultimately show ?case using * by auto
qed simp_all
private lemma strand_sem_subst_c':
assumes "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "⟦M; S ⋅⇩s⇩t δ⟧⇩c θ ⟹ ⟦M; S⟧⇩c (δ ∘⇩s θ)"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
case (ConsSnd M t S)
hence "⟦M; [Send t] ⋅⇩s⇩t δ⟧⇩c θ" "⟦M; S ⋅⇩s⇩t δ⟧⇩c θ" by auto
hence "⟦M; S⟧⇩c (δ ∘⇩s θ)" using ConsSnd.IH[OF _] ConsSnd.prems(2) by auto
moreover have "⟦M; [Send t]⟧⇩c (δ ∘⇩s θ)"
proof -
have "M ⊢⇩c t ⋅ δ ⋅ θ" using ‹⟦M; [Send t] ⋅⇩s⇩t δ⟧⇩c θ› by auto
hence "M ⊢⇩c t ⋅ (δ ∘⇩s θ)" using subst_subst_compose by metis
thus "⟦M; [Send t]⟧⇩c (δ ∘⇩s θ)" by auto
qed
ultimately show ?case by auto
next
case (ConsRcv M t S)
hence "⟦(insert (t ⋅ δ ⋅ θ) M); S ⋅⇩s⇩t δ⟧⇩c θ" by (simp add: subst_all_insert)
thus ?case using ConsRcv.IH ConsRcv.prems(2) by auto
next
case (ConsIneq M X F S)
have δ: "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
hence *: "⟦M; S⟧⇩c (δ ∘⇩s θ)"
and ***: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
using ConsIneq unfolding bvars⇩s⇩t_def ineq_model_def by auto
have **: "ineq_model θ X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using ConsIneq.prems(1) δ by (auto simp add: subst_compose_assoc ineq_model_def)
have "∀γ. subst_domain γ = set X ∧ ground (subst_range γ)
⟶ (subst_domain δ ∪ range_vars δ) ∩ (subst_domain γ ∪ range_vars γ) = {}"
using * ** *** unfolding range_vars_alt_def by auto
hence "∀γ. subst_domain γ = set X ∧ ground (subst_range γ) ⟶ γ ∘⇩s δ = δ ∘⇩s γ"
by (metis subst_comp_eq_if_disjoint_vars)
hence "ineq_model (δ ∘⇩s θ) X F"
using ineq_model_subst'[OF *** **]
by blast
thus ?case using * by auto
next
case ConsEq thus ?case unfolding bvars⇩s⇩t_def by auto
qed simp_all
private lemma strand_sem_subst_d:
assumes "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "⟦M; S⟧⇩d (δ ∘⇩s θ) ⟹ ⟦M; S ⋅⇩s⇩t δ⟧⇩d θ"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
case (ConsSnd M t S)
hence "⟦M; S ⋅⇩s⇩t δ⟧⇩d θ" "M ⊢ t ⋅ (δ ∘⇩s θ)" by auto
hence "M ⊢ (t ⋅ δ) ⋅ θ"
using subst_comp_all[of δ θ M] subst_subst_compose[of t δ θ] by simp
thus ?case using ‹⟦M; S ⋅⇩s⇩t δ⟧⇩d θ› by simp
next
case (ConsRcv M t S)
have *: "⟦insert (t ⋅ δ ∘⇩s θ) M; S⟧⇩d (δ ∘⇩s θ)" using ConsRcv.prems(1) by simp
have "bvars⇩s⇩t (Receive t#S) = bvars⇩s⇩t S" by auto
hence **: "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}" using ConsRcv.prems(2) by blast
have "⟦M; Receive (t ⋅ δ)#(S ⋅⇩s⇩t δ)⟧⇩d θ"
using ConsRcv.IH[OF * **] by (simp add: subst_all_insert)
thus ?case by simp
next
case (ConsIneq M X F S)
hence *: "⟦M; S ⋅⇩s⇩t δ⟧⇩d θ" and
***: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
unfolding bvars⇩s⇩t_def ineq_model_def by auto
have **: "ineq_model (δ ∘⇩s θ) X F"
using ConsIneq by (auto simp add: subst_compose_assoc ineq_model_def)
have "∀γ. subst_domain γ = set X ∧ ground (subst_range γ)
⟶ (subst_domain δ ∪ range_vars δ) ∩ (subst_domain γ ∪ range_vars γ) = {}"
using * ** *** unfolding range_vars_alt_def by auto
hence "∀γ. subst_domain γ = set X ∧ ground (subst_range γ) ⟶ γ ∘⇩s δ = δ ∘⇩s γ"
by (metis subst_comp_eq_if_disjoint_vars)
hence "ineq_model θ X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using ineq_model_subst[OF *** **]
by blast
moreover have "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
ultimately show ?case using * by auto
next
case ConsEq thus ?case unfolding bvars⇩s⇩t_def by auto
qed simp_all
private lemma strand_sem_subst_d':
assumes "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "⟦M; S ⋅⇩s⇩t δ⟧⇩d θ ⟹ ⟦M; S⟧⇩d (δ ∘⇩s θ)"
using assms
proof (induction S arbitrary: δ M rule: strand_sem_induct)
case (ConsSnd M t S)
hence "⟦M; [Send t] ⋅⇩s⇩t δ⟧⇩d θ" "⟦M; S ⋅⇩s⇩t δ⟧⇩d θ" by auto
hence "⟦M; S⟧⇩d (δ ∘⇩s θ)" using ConsSnd.IH[OF _] ConsSnd.prems(2) by auto
moreover have "⟦M; [Send t]⟧⇩d (δ ∘⇩s θ)"
proof -
have "M ⊢ t ⋅ δ ⋅ θ" using ‹⟦M; [Send t] ⋅⇩s⇩t δ⟧⇩d θ› by auto
hence "M ⊢ t ⋅ (δ ∘⇩s θ)" using subst_subst_compose by metis
thus "⟦M; [Send t]⟧⇩d (δ ∘⇩s θ)" by auto
qed
ultimately show ?case by auto
next
case (ConsRcv M t S)
hence "⟦insert (t ⋅ δ ⋅ θ) M; S ⋅⇩s⇩t δ⟧⇩d θ" by (simp add: subst_all_insert)
thus ?case using ConsRcv.IH ConsRcv.prems(2) by auto
next
case (ConsIneq M X F S)
have δ: "rm_vars (set X) δ = δ" using ConsIneq.prems(2) by force
hence *: "⟦M; S⟧⇩d (δ ∘⇩s θ)"
and ***: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
using ConsIneq unfolding bvars⇩s⇩t_def ineq_model_def by auto
have **: "ineq_model θ X (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using ConsIneq.prems(1) δ by (auto simp add: subst_compose_assoc ineq_model_def)
have "∀γ. subst_domain γ = set X ∧ ground (subst_range γ)
⟶ (subst_domain δ ∪ range_vars δ) ∩ (subst_domain γ ∪ range_vars γ) = {}"
using * ** *** unfolding range_vars_alt_def by auto
hence "∀γ. subst_domain γ = set X ∧ ground (subst_range γ) ⟶ γ ∘⇩s δ = δ ∘⇩s γ"
by (metis subst_comp_eq_if_disjoint_vars)
hence "ineq_model (δ ∘⇩s θ) X F"
using ineq_model_subst'[OF *** **]
by blast
thus ?case using * by auto
next
case ConsEq thus ?case unfolding bvars⇩s⇩t_def by auto
qed simp_all
lemmas strand_sem_subst =
strand_sem_subst_c strand_sem_subst_c' strand_sem_subst_d strand_sem_subst_d'
end
lemma strand_sem_subst_subst_idem:
assumes δ: "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t S = {}"
shows "⟦⟦M; S ⋅⇩s⇩t δ⟧⇩c (δ ∘⇩s θ); subst_idem δ⟧ ⟹ ⟦M; S⟧⇩c (δ ∘⇩s θ)"
using strand_sem_subst(2)[OF assms, of M "δ ∘⇩s θ"] subst_compose_assoc[of δ δ θ]
unfolding subst_idem_def by argo
lemma strand_sem_subst_comp:
assumes "(subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t S = {}"
and "⟦M; S⟧⇩c δ" "subst_domain θ ∩ (vars⇩s⇩t S ∪ fv⇩s⇩e⇩t M) = {}"
shows "⟦M; S⟧⇩c (θ ∘⇩s δ)"
proof -
from assms(3) have "subst_domain θ ∩ vars⇩s⇩t S = {}" "subst_domain θ ∩ fv⇩s⇩e⇩t M = {}" by auto
hence "S ⋅⇩s⇩t θ = S" "M ⋅⇩s⇩e⇩t θ = M" using strand_substI set_subst_ident[of M θ] by (blast, blast)
thus ?thesis using assms(2) by (auto simp add: strand_sem_subst(2)[OF assms(1)])
qed
lemma strand_sem_c_imp_ineqs_neq:
assumes "⟦M; S⟧⇩c ℐ" "Inequality X [(t,t')] ∈ set S"
shows "t ≠ t' ∧ (∀δ. subst_domain δ = set X ∧ ground (subst_range δ)
⟶ t ⋅ δ ≠ t' ⋅ δ ∧ t ⋅ δ ⋅ ℐ ≠ t' ⋅ δ ⋅ ℐ)"
using assms
proof (induction rule: strand_sem_induct)
case (ConsIneq M Y F S) thus ?case
proof (cases "Inequality X [(t,t')] ∈ set S")
case False
hence "X = Y" "F = [(t,t')]" using ConsIneq by auto
hence *: "∀θ. subst_domain θ = set X ∧ ground (subst_range θ) ⟶ t ⋅ θ ⋅ ℐ ≠ t' ⋅ θ ⋅ ℐ"
using ConsIneq by (auto simp add: ineq_model_def)
then obtain θ where θ: "subst_domain θ = set X" "ground (subst_range θ)" "t ⋅ θ ⋅ ℐ ≠ t' ⋅ θ ⋅ ℐ"
using interpretation_subst_exists'[of "set X"] by moura
hence "t ≠ t'" by auto
moreover have "⋀ℐ θ. t ⋅ θ ⋅ ℐ ≠ t' ⋅ θ ⋅ ℐ ⟹ t ⋅ θ ≠ t' ⋅ θ" by auto
ultimately show ?thesis using * by auto
qed simp
qed simp_all
lemma strand_sem_c_imp_ineq_model:
assumes "⟦M; S⟧⇩c ℐ" "Inequality X F ∈ set S"
shows "ineq_model ℐ X F"
using assms by (induct S rule: strand_sem_induct) force+
lemma strand_sem_wf_simple_fv_sat:
assumes "wf⇩s⇩t {} S" "simple S" "⟦{}; S⟧⇩c ℐ"
shows "⋀v. v ∈ wfrestrictedvars⇩s⇩t S ⟹ ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊢⇩c ℐ v"
using assms
proof (induction S rule: wf⇩s⇩t_simple_induct)
case (ConsRcv t S)
have "v ∈ wfrestrictedvars⇩s⇩t S"
using ConsRcv.hyps(3) ConsRcv.prems(1) vars_snd_rcv_strand2
by fastforce
moreover have "⟦{}; S⟧⇩c ℐ" using ‹⟦{}; S@[Receive t]⟧⇩c ℐ› by blast
moreover have "ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊆ ik⇩s⇩t (S@[Receive t]) ⋅⇩s⇩e⇩t ℐ" by auto
ultimately show ?case using ConsRcv.IH ideduct_synth_mono by meson
next
case (ConsIneq X F S)
hence "v ∈ wfrestrictedvars⇩s⇩t S" by fastforce
moreover have "⟦{}; S⟧⇩c ℐ" using ‹⟦{}; S@[Inequality X F]⟧⇩c ℐ› by blast
moreover have "ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊆ ik⇩s⇩t (S@[Inequality X F]) ⋅⇩s⇩e⇩t ℐ" by auto
ultimately show ?case using ConsIneq.IH ideduct_synth_mono by meson
next
case (ConsSnd w S)
hence *: "⟦{}; S⟧⇩c ℐ" "ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊢⇩c ℐ w" by auto
have **: "ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊆ ik⇩s⇩t (S@[Send (Var w)]) ⋅⇩s⇩e⇩t ℐ" by simp
show ?case
proof (cases "v = w")
case True thus ?thesis using *(2) ideduct_synth_mono[OF _ **] by meson
next
case False
hence "v ∈ wfrestrictedvars⇩s⇩t S" using ConsSnd.prems(1) by auto
thus ?thesis using ConsSnd.IH[OF _ *(1)] ideduct_synth_mono[OF _ **] by metis
qed
qed simp
lemma strand_sem_wf_ik_or_assignment_rhs_fun_subterm:
assumes "wf⇩s⇩t {} A" "⟦{}; A⟧⇩c ℐ" "Var x ∈ ik⇩s⇩t A" "ℐ x = Fun f T"
"t⇩i ∈ set T" "¬ik⇩s⇩t A ⋅⇩s⇩e⇩t ℐ ⊢⇩c t⇩i" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
obtains S where
"Fun f S ∈ subterms⇩s⇩e⇩t (ik⇩s⇩t A) ∨ Fun f S ∈ subterms⇩s⇩e⇩t (assignment_rhs⇩s⇩t A)"
"Fun f T = Fun f S ⋅ ℐ"
proof -
have "x ∈ wfrestrictedvars⇩s⇩t A"
by (metis (no_types) assms(3) set_rev_mp term.set_intros(3) vars_subset_if_in_strand_ik2)
moreover have "Fun f T ⋅ ℐ = Fun f T"
by (metis subst_ground_ident interpretation_grounds_all assms(4,7))
ultimately obtain A⇩p⇩r⇩e A⇩s⇩u⇩f where *:
"¬(∃w ∈ wfrestrictedvars⇩s⇩t A⇩p⇩r⇩e. Fun f T ⊑ ℐ w)"
"(∃t. A = A⇩p⇩r⇩e@Send t#A⇩s⇩u⇩f ∧ Fun f T ⊑ t ⋅ ℐ) ∨
(∃t t'. A = A⇩p⇩r⇩e@Equality Assign t t'#A⇩s⇩u⇩f ∧ Fun f T ⊑ t ⋅ ℐ)"
using wf_strand_first_Send_var_split[OF assms(1)] assms(4) subtermeqI' by metis
moreover
{ fix t assume **: "A = A⇩p⇩r⇩e@Send t#A⇩s⇩u⇩f" "Fun f T ⊑ t ⋅ ℐ"
hence "ik⇩s⇩t A⇩p⇩r⇩e ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ" "¬ik⇩s⇩t A⇩p⇩r⇩e ⋅⇩s⇩e⇩t ℐ ⊢⇩c t⇩i"
using assms(2,6) by (auto intro: ideduct_synth_mono)
then obtain s where s: "s ∈ ik⇩s⇩t A⇩p⇩r⇩e" "Fun f T ⊑ s ⋅ ℐ"
using assms(5) **(2) by (induct rule: intruder_synth_induct) auto
then obtain g S where gS: "Fun g S ⊑ s" "Fun f T = Fun g S ⋅ ℐ"
using subterm_subst_not_img_subterm[OF s(2)] *(1) by force
hence ?thesis using that **(1) s(1) by force
}
moreover
{ fix t t' assume **: "A = A⇩p⇩r⇩e@Equality Assign t t'#A⇩s⇩u⇩f" "Fun f T ⊑ t ⋅ ℐ"
with assms(2) have "t ⋅ ℐ = t' ⋅ ℐ" by auto
hence "Fun f T ⊑ t' ⋅ ℐ" using **(2) by auto
from assms(1) **(1) have "fv t' ⊆ wfrestrictedvars⇩s⇩t A⇩p⇩r⇩e"
using wf_eq_fv[of "{}" A⇩p⇩r⇩e t t' A⇩s⇩u⇩f] vars_snd_rcv_strand_subset2(4)[of A⇩p⇩r⇩e]
by blast
then obtain g S where gS: "Fun g S ⊑ t'" "Fun f T = Fun g S ⋅ ℐ"
using subterm_subst_not_img_subterm[OF ‹Fun f T ⊑ t' ⋅ ℐ›] *(1) by fastforce
hence ?thesis using that **(1) by auto
}
ultimately show ?thesis by auto
qed
lemma strand_sem_not_unif_is_sat_ineq:
assumes "∄θ. Unifier θ t t'"
shows "⟦M; [Inequality X [(t,t')]]⟧⇩c ℐ" "⟦M; [Inequality X [(t,t')]]⟧⇩d ℐ"
using assms list_ex_simps(1)[of _ "(t,t')" "[]"] prod.sel[of t t']
strand_sem_c.simps(1,5) strand_sem_d.simps(1,5)
unfolding ineq_model_def by presburger+
lemma ineq_model_singleI[intro]:
assumes "∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶ t ⋅ δ ⋅ ℐ ≠ t' ⋅ δ ⋅ ℐ"
shows "ineq_model ℐ X [(t,t')]"
using assms unfolding ineq_model_def by auto
lemma ineq_model_singleE:
assumes "ineq_model ℐ X [(t,t')]"
shows "∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶ t ⋅ δ ⋅ ℐ ≠ t' ⋅ δ ⋅ ℐ"
using assms unfolding ineq_model_def by auto
lemma ineq_model_single_iff:
fixes F::"(('a,'b) term × ('a,'b) term) list"
shows "ineq_model ℐ X F ⟷
ineq_model ℐ X [(Fun f (Fun c []#map fst F),Fun f (Fun c []#map snd F))]"
(is "?A ⟷ ?B")
proof -
let ?P = "λδ f. fst f ⋅ (δ ∘⇩s ℐ) ≠ snd f ⋅ (δ ∘⇩s ℐ)"
let ?Q = "λδ t t'. t ⋅ (δ ∘⇩s ℐ) ≠ t' ⋅ (δ ∘⇩s ℐ)"
let ?T = "λg. Fun c []#map g F"
let ?S = "λδ g. map (λx. x ⋅ (δ ∘⇩s ℐ)) (Fun c []#map g F)"
let ?t = "Fun f (?T fst)"
let ?t' = "Fun f (?T snd)"
have len: "⋀g h. length (?T g) = length (?T h)"
"⋀g h δ. length (?S δ g) = length (?T h)"
"⋀g h δ. length (?S δ g) = length (?T h)"
"⋀g h δ σ. length (?S δ g) = length (?S σ h)"
by simp_all
{ fix δ::"('a,'b) subst"
assume δ: "subst_domain δ = set X" "ground (subst_range δ)"
have "list_ex (?P δ) F ⟷ ?Q δ ?t ?t'"
proof
assume "list_ex (?P δ) F"
then obtain a where a: "a ∈ set F" "?P δ a" by (metis (mono_tags, lifting) Bex_set)
thus "?Q δ ?t ?t'" by auto
qed (fastforce simp add: Bex_set)
} thus ?thesis unfolding ineq_model_def by auto
qed
subsection ‹Constraint Semantics (Alternative, Equivalent Version)›
text ‹These are the constraint semantics used in the CSF 2017 paper›
fun strand_sem_c'::"('fun,'var) terms ⇒ ('fun,'var) strand ⇒ ('fun,'var) subst ⇒ bool" ("⟦_; _⟧⇩c''")
where
"⟦M; []⟧⇩c' = (λℐ. True)"
| "⟦M; Send t#S⟧⇩c' = (λℐ. M ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ ∧ ⟦M; S⟧⇩c' ℐ)"
| "⟦M; Receive t#S⟧⇩c' = ⟦insert t M; S⟧⇩c'"
| "⟦M; Equality _ t t'#S⟧⇩c' = (λℐ. t ⋅ ℐ = t' ⋅ ℐ ∧ ⟦M; S⟧⇩c' ℐ)"
| "⟦M; Inequality X F#S⟧⇩c' = (λℐ. ineq_model ℐ X F ∧ ⟦M; S⟧⇩c' ℐ)"
fun strand_sem_d'::"('fun,'var) terms ⇒ ('fun,'var) strand ⇒ ('fun,'var) subst ⇒ bool" ("⟦_; _⟧⇩d''")
where
"⟦M; []⟧⇩d' = (λℐ. True)"
| "⟦M; Send t#S⟧⇩d' = (λℐ. M ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ ∧ ⟦M; S⟧⇩d' ℐ)"
| "⟦M; Receive t#S⟧⇩d' = ⟦insert t M; S⟧⇩d'"
| "⟦M; Equality _ t t'#S⟧⇩d' = (λℐ. t ⋅ ℐ = t' ⋅ ℐ ∧ ⟦M; S⟧⇩d' ℐ)"
| "⟦M; Inequality X F#S⟧⇩d' = (λℐ. ineq_model ℐ X F ∧ ⟦M; S⟧⇩d' ℐ)"
lemma strand_sem_eq_defs:
"⟦M; 𝒜⟧⇩c' ℐ = ⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩c ℐ"
"⟦M; 𝒜⟧⇩d' ℐ = ⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩d ℐ"
proof -
have 1: "⟦M; 𝒜⟧⇩c' ℐ ⟹ ⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩c ℐ"
by (induct 𝒜 arbitrary: M rule: strand_sem_induct) force+
have 2: "⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩c ℐ ⟹ ⟦M; 𝒜⟧⇩c' ℐ"
by (induct 𝒜 arbitrary: M rule: strand_sem_c'.induct) auto
have 3: "⟦M; 𝒜⟧⇩d' ℐ ⟹ ⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩d ℐ"
by (induct 𝒜 arbitrary: M rule: strand_sem_induct) force+
have 4: "⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩d ℐ ⟹ ⟦M; 𝒜⟧⇩d' ℐ"
by (induct 𝒜 arbitrary: M rule: strand_sem_d'.induct) auto
show "⟦M; 𝒜⟧⇩c' ℐ = ⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩c ℐ" "⟦M; 𝒜⟧⇩d' ℐ = ⟦M ⋅⇩s⇩e⇩t ℐ; 𝒜⟧⇩d ℐ"
by (metis 1 2, metis 3 4)
qed
lemma strand_sem_split'[dest]:
"⟦M; S@S'⟧⇩c' θ ⟹ ⟦M; S⟧⇩c' θ"
"⟦M; S@S'⟧⇩c' θ ⟹ ⟦M ∪ ik⇩s⇩t S; S'⟧⇩c' θ"
"⟦M; S@S'⟧⇩d' θ ⟹ ⟦M; S⟧⇩d' θ"
"⟦M; S@S'⟧⇩d' θ ⟹ ⟦M ∪ ik⇩s⇩t S; S'⟧⇩d' θ"
using strand_sem_eq_defs[of M "S@S'" θ]
strand_sem_eq_defs[of M S θ]
strand_sem_eq_defs[of "M ∪ ik⇩s⇩t S" S' θ]
strand_sem_split(2,4)
by (auto simp add: image_Un)
lemma strand_sem_append'[intro]:
"⟦M; S⟧⇩c' θ ⟹ ⟦M ∪ ik⇩s⇩t S; S'⟧⇩c' θ ⟹ ⟦M; S@S'⟧⇩c' θ"
"⟦M; S⟧⇩d' θ ⟹ ⟦M ∪ ik⇩s⇩t S; S'⟧⇩d' θ ⟹ ⟦M; S@S'⟧⇩d' θ"
using strand_sem_eq_defs[of M "S@S'" θ]
strand_sem_eq_defs[of M S θ]
strand_sem_eq_defs[of "M ∪ ik⇩s⇩t S" S' θ]
by (auto simp add: image_Un)
end
subsection ‹Dual Strands›
fun dual⇩s⇩t::"('a,'b) strand ⇒ ('a,'b) strand" where
"dual⇩s⇩t [] = []"
| "dual⇩s⇩t (Receive t#S) = Send t#(dual⇩s⇩t S)"
| "dual⇩s⇩t (Send t#S) = Receive t#(dual⇩s⇩t S)"
| "dual⇩s⇩t (x#S) = x#(dual⇩s⇩t S)"
lemma dual⇩s⇩t_append: "dual⇩s⇩t (A@B) = (dual⇩s⇩t A)@(dual⇩s⇩t B)"
by (induct A rule: dual⇩s⇩t.induct) auto
lemma dual⇩s⇩t_self_inverse: "dual⇩s⇩t (dual⇩s⇩t S) = S"
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
lemma dual⇩s⇩t_trms_eq: "trms⇩s⇩t (dual⇩s⇩t S) = trms⇩s⇩t S"
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
lemma dual⇩s⇩t_fv: "fv⇩s⇩t (dual⇩s⇩t A) = fv⇩s⇩t A"
by (induct A rule: dual⇩s⇩t.induct) auto
lemma dual⇩s⇩t_bvars: "bvars⇩s⇩t (dual⇩s⇩t A) = bvars⇩s⇩t A"
by (induct A rule: dual⇩s⇩t.induct) fastforce+
end
Theory Lazy_Intruder
section ‹The Lazy Intruder›
theory Lazy_Intruder
imports Strands_and_Constraints Intruder_Deduction
begin
context intruder_model
begin
subsection ‹Definition of the Lazy Intruder›
text ‹The lazy intruder constraint reduction system, defined as a relation on constraint states›
inductive_set LI_rel::
"((('fun,'var) strand × (('fun,'var) subst)) ×
('fun,'var) strand × (('fun,'var) subst)) set"
and LI_rel' (infix "↝" 50)
and LI_rel_trancl (infix "↝⇧+" 50)
and LI_rel_rtrancl (infix "↝⇧*" 50)
where
"A ↝ B ≡ (A,B) ∈ LI_rel"
| "A ↝⇧+ B ≡ (A,B) ∈ LI_rel⇧+"
| "A ↝⇧* B ≡ (A,B) ∈ LI_rel⇧*"
| Compose: "⟦simple S; length T = arity f; public f⟧
⟹ (S@Send (Fun f T)#S',θ) ↝ (S@(map Send T)@S',θ)"
| Unify: "⟦simple S; Fun f T' ∈ ik⇩s⇩t S; Some δ = mgu (Fun f T) (Fun f T')⟧
⟹ (S@Send (Fun f T)#S',θ) ↝ ((S@S') ⋅⇩s⇩t δ,θ ∘⇩s δ)"
| Equality: "⟦simple S; Some δ = mgu t t'⟧
⟹ (S@Equality _ t t'#S',θ) ↝ ((S@S') ⋅⇩s⇩t δ,θ ∘⇩s δ)"
subsection ‹Lemma: The Lazy Intruder is Well-founded›
context
begin
private lemma LI_compose_measure_lt: "((S@(map Send T)@S',θ⇩1), (S@Send (Fun f T)#S',θ⇩2)) ∈ measure⇩s⇩t"
using strand_fv_card_map_fun_eq[of S f T S'] strand_size_map_fun_lt(2)[of T f]
by (simp add: measure⇩s⇩t_def size⇩s⇩t_def)
private lemma LI_unify_measure_lt:
assumes "Some δ = mgu (Fun f T) t" "fv t ⊆ fv⇩s⇩t S"
shows "(((S@S') ⋅⇩s⇩t δ,θ⇩1), (S@Send (Fun f T)#S',θ⇩2)) ∈ measure⇩s⇩t"
proof (cases "δ = Var")
assume "δ = Var"
hence "(S@S') ⋅⇩s⇩t δ = S@S'" by blast
thus ?thesis
using strand_fv_card_rm_fun_le[of S S' f T]
by (auto simp add: measure⇩s⇩t_def size⇩s⇩t_def)
next
assume "δ ≠ Var"
then obtain v where "v ∈ fv (Fun f T) ∪ fv t" "subst_elim δ v"
using mgu_eliminates[OF assms(1)[symmetric]] by metis
hence v_in: "v ∈ fv⇩s⇩t (S@Send (Fun f T)#S')"
using assms(2) by (auto simp add: measure⇩s⇩t_def size⇩s⇩t_def)
have "range_vars δ ⊆ fv (Fun f T) ∪ fv⇩s⇩t S"
using assms(2) mgu_vars_bounded[OF assms(1)[symmetric]] by auto
hence img_bound: "range_vars δ ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')" by auto
have finite_fv: "finite (fv⇩s⇩t (S@Send (Fun f T)#S'))" by auto
have "v ∉ fv⇩s⇩t ((S@Send (Fun f T)#S') ⋅⇩s⇩t δ)"
using strand_fv_subst_subset_if_subst_elim[OF ‹subst_elim δ v›] v_in by metis
hence v_not_in: "v ∉ fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ)" by auto
have "fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')"
using strand_subst_fv_bounded_if_img_bounded[OF img_bound] by simp
hence "fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ⊂ fv⇩s⇩t (S@Send (Fun f T)#S')" using v_in v_not_in by blast
hence "card (fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ)) < card (fv⇩s⇩t (S@Send (Fun f T)#S'))"
using psubset_card_mono[OF finite_fv] by simp
thus ?thesis by (auto simp add: measure⇩s⇩t_def size⇩s⇩t_def)
qed
private lemma LI_equality_measure_lt:
assumes "Some δ = mgu t t'"
shows "(((S@S') ⋅⇩s⇩t δ,θ⇩1), (S@Equality a t t'#S',θ⇩2)) ∈ measure⇩s⇩t"
proof (cases "δ = Var")
assume "δ = Var"
hence "(S@S') ⋅⇩s⇩t δ = S@S'" by blast
thus ?thesis
using strand_fv_card_rm_eq_le[of S S' a t t']
by (auto simp add: measure⇩s⇩t_def size⇩s⇩t_def)
next
assume "δ ≠ Var"
then obtain v where "v ∈ fv t ∪ fv t'" "subst_elim δ v"
using mgu_eliminates[OF assms(1)[symmetric]] by metis
hence v_in: "v ∈ fv⇩s⇩t (S@Equality a t t'#S')" using assms by auto
have "range_vars δ ⊆ fv t ∪ fv t' ∪ fv⇩s⇩t S"
using assms mgu_vars_bounded[OF assms(1)[symmetric]] by auto
hence img_bound: "range_vars δ ⊆ fv⇩s⇩t (S@Equality a t t'#S')" by auto
have finite_fv: "finite (fv⇩s⇩t (S@Equality a t t'#S'))" by auto
have "v ∉ fv⇩s⇩t ((S@Equality a t t'#S') ⋅⇩s⇩t δ)"
using strand_fv_subst_subset_if_subst_elim[OF ‹subst_elim δ v›] v_in by metis
hence v_not_in: "v ∉ fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ)" by auto
have "fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ⊆ fv⇩s⇩t (S@Equality a t t'#S')"
using strand_subst_fv_bounded_if_img_bounded[OF img_bound] by simp
hence "fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ) ⊂ fv⇩s⇩t (S@Equality a t t'#S')" using v_in v_not_in by blast
hence "card (fv⇩s⇩t ((S@S') ⋅⇩s⇩t δ)) < card (fv⇩s⇩t (S@Equality a t t'#S'))"
using psubset_card_mono[OF finite_fv] by simp
thus ?thesis by (auto simp add: measure⇩s⇩t_def size⇩s⇩t_def)
qed
private lemma LI_in_measure: "(S⇩1,θ⇩1) ↝ (S⇩2,θ⇩2) ⟹ ((S⇩2,θ⇩2),(S⇩1,θ⇩1)) ∈ measure⇩s⇩t"
proof (induction rule: LI_rel.induct)
case (Compose S T f S' θ) thus ?case using LI_compose_measure_lt[of S T S'] by metis
next
case (Unify S f U δ T S' θ)
hence "fv (Fun f U) ⊆ fv⇩s⇩t S"
using fv_snd_rcv_strand_subset(2)[of S] by force
thus ?case using LI_unify_measure_lt[OF Unify.hyps(3), of S S'] by metis
qed (metis LI_equality_measure_lt)
private lemma LI_in_measure_trans: "(S⇩1,θ⇩1) ↝⇧+ (S⇩2,θ⇩2) ⟹ ((S⇩2,θ⇩2),(S⇩1,θ⇩1)) ∈ measure⇩s⇩t"
by (induction rule: trancl.induct, metis surjective_pairing LI_in_measure)
(metis (no_types, lifting) surjective_pairing LI_in_measure measure⇩s⇩t_trans trans_def)
private lemma LI_converse_wellfounded_trans: "wf ((LI_rel⇧+)¯)"
proof -
have "(LI_rel⇧+)¯ ⊆ measure⇩s⇩t" using LI_in_measure_trans by auto
thus ?thesis using measure⇩s⇩t_wellfounded wf_subset by metis
qed
private lemma LI_acyclic_trans: "acyclic (LI_rel⇧+)"
using wf_acyclic[OF LI_converse_wellfounded_trans] acyclic_converse by metis
private lemma LI_acyclic: "acyclic LI_rel"
using LI_acyclic_trans acyclic_subset by (simp add: acyclic_def)
lemma LI_no_infinite_chain: "¬(∃f. ∀i. f i ↝⇧+ f (Suc i))"
proof -
have "¬(∃f. ∀i. (f (Suc i), f i) ∈ (LI_rel⇧+)¯)"
using wf_iff_no_infinite_down_chain LI_converse_wellfounded_trans by metis
thus ?thesis by simp
qed
private lemma LI_unify_finite:
assumes "finite M"
shows "finite {((S@Send (Fun f T)#S',θ), ((S@S') ⋅⇩s⇩t δ,θ ∘⇩s δ)) | δ T'.
simple S ∧ Fun f T' ∈ M ∧ Some δ = mgu (Fun f T) (Fun f T')}"
using assms
proof (induction M rule: finite_induct)
case (insert m M) thus ?case
proof (cases m)
case (Fun g U)
let ?a = "λδ. ((S@Send (Fun f T)#S',θ), ((S@S') ⋅⇩s⇩t δ,θ ∘⇩s δ))"
let ?A = "λB. {?a δ | δ T'. simple S ∧ Fun f T' ∈ B ∧ Some δ = mgu (Fun f T) (Fun f T')}"
have "?A (insert m M) = (?A M) ∪ (?A {m})" by auto
moreover have "finite (?A {m})"
proof (cases "∃δ. Some δ = mgu (Fun f T) (Fun g U)")
case True
then obtain δ where δ: "Some δ = mgu (Fun f T) (Fun g U)" by blast
have A_m_eq: "⋀δ'. ?a δ' ∈ ?A {m} ⟹ ?a δ = ?a δ'"
proof -
fix δ' assume "?a δ' ∈ ?A {m}"
hence "∃σ. Some σ = mgu (Fun f T) (Fun g U) ∧ ?a σ = ?a δ'"
using ‹m = Fun g U› by auto
thus "?a δ = ?a δ'" by (metis δ option.inject)
qed
have "?A {m} = {} ∨ ?A {m} = {?a δ}"
proof (cases "simple S ∧ ?A {m} ≠ {}")
case True
hence "simple S" "?A {m} ≠ {}" by meson+
hence "?A {m} = {?a δ | δ. Some δ = mgu (Fun f T) (Fun g U)}" using ‹m = Fun g U› by auto
hence "?a δ ∈ ?A {m}" using δ by auto
show ?thesis
proof (rule ccontr)
assume "¬(?A {m} = {} ∨ ?A {m} = {?a δ})"
then obtain B where B: "?A {m} = insert (?a δ) B" "?a δ ∉ B" "B ≠ {}"
using ‹?A {m} ≠ {}› ‹?a δ ∈ ?A {m}› by (metis (no_types, lifting) Set.set_insert)
then obtain b where b: "?a δ ≠ b" "b ∈ B" by (metis (no_types, lifting) ex_in_conv)
then obtain δ' where δ': "b = ?a δ'" using B(1) by blast
moreover have "?a δ' ∈ ?A {m}" using B(1) b(2) δ' by auto
hence "?a δ = ?a δ'" by (blast dest!: A_m_eq)
ultimately show False using b(1) by simp
qed
qed auto
thus ?thesis by (metis (no_types, lifting) finite.emptyI finite_insert)
next
case False
hence "?A {m} = {}" using ‹m = Fun g U› by blast
thus ?thesis by (metis finite.emptyI)
qed
ultimately show ?thesis using insert.IH by auto
qed simp
qed fastforce
end
subsection ‹Lemma: The Lazy Intruder Preserves Well-formedness›
context
begin
private lemma LI_preserves_subst_wf_single:
assumes "(S⇩1,θ⇩1) ↝ (S⇩2,θ⇩2)" "fv⇩s⇩t S⇩1 ∩ bvars⇩s⇩t S⇩1 = {}" "wf⇩s⇩u⇩b⇩s⇩t θ⇩1"
and "subst_domain θ⇩1 ∩ vars⇩s⇩t S⇩1 = {}" "range_vars θ⇩1 ∩ bvars⇩s⇩t S⇩1 = {}"
shows "fv⇩s⇩t S⇩2 ∩ bvars⇩s⇩t S⇩2 = {}" "wf⇩s⇩u⇩b⇩s⇩t θ⇩2"
and "subst_domain θ⇩2 ∩ vars⇩s⇩t S⇩2 = {}" "range_vars θ⇩2 ∩ bvars⇩s⇩t S⇩2 = {}"
using assms
proof (induction rule: LI_rel.induct)
case (Compose S X f S' θ)
{ case 1 thus ?case using vars_st_snd_map by auto }
{ case 2 thus ?case using vars_st_snd_map by auto }
{ case 3 thus ?case using vars_st_snd_map by force }
{ case 4 thus ?case using vars_st_snd_map by auto }
next
case (Unify S f U δ T S' θ)
hence "fv (Fun f U) ⊆ fv⇩s⇩t S" using fv_subset_if_in_strand_ik' by blast
hence *: "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')"
using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]]
unfolding range_vars_alt_def by (fastforce simp del: subst_range.simps)
have "fv⇩s⇩t (S@S') ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')" "vars⇩s⇩t (S@S') ⊆ vars⇩s⇩t (S@Send (Fun f T)#S')"
by auto
hence **: "fv⇩s⇩t (S@S' ⋅⇩s⇩t δ) ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')"
"vars⇩s⇩t (S@S' ⋅⇩s⇩t δ) ⊆ vars⇩s⇩t (S@Send (Fun f T)#S')"
using subst_sends_strand_fv_to_img[of "S@S'" δ]
strand_subst_vars_union_bound[of "S@S'" δ] *
by blast+
have "wf⇩s⇩u⇩b⇩s⇩t δ" by (fact mgu_gives_wellformed_subst[OF Unify.hyps(3)[symmetric]])
{ case 1
have "bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = bvars⇩s⇩t (S@Send (Fun f T)#S')"
using bvars_subst_ident[of "S@S'" δ] by auto
thus ?case using 1 ** by blast
}
{ case 2
hence "subst_domain θ ∩ subst_domain δ = {}" "subst_domain θ ∩ range_vars δ = {}"
using * by blast+
thus ?case by (metis wf_subst_compose[OF ‹wf⇩s⇩u⇩b⇩s⇩t θ› ‹wf⇩s⇩u⇩b⇩s⇩t δ›])
}
{ case 3
hence "subst_domain θ ∩ vars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}" using ** by blast
moreover have "v ∈ fv⇩s⇩t (S@Send (Fun f T)#S')" when "v ∈ subst_domain δ" for v
using * that by blast
hence "subst_domain δ ∩ fv⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}"
using mgu_eliminates_dom[OF Unify.hyps(3)[symmetric],
THEN strand_fv_subst_subset_if_subst_elim, of _ "S@Send (Fun f T)#S'"]
unfolding subst_elim_def by auto
moreover have "bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = bvars⇩s⇩t (S@Send (Fun f T)#S')"
using bvars_subst_ident[of "S@S'" δ] by auto
hence "subst_domain δ ∩ bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}" using 3(1) * by blast
ultimately show ?case
using ** * subst_domain_compose[of θ δ] vars⇩s⇩t_is_fv⇩s⇩t_bvars⇩s⇩t[of "S@S' ⋅⇩s⇩t δ"]
by blast
}
{ case 4
have ***: "bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = bvars⇩s⇩t (S@Send (Fun f T)#S')"
using bvars_subst_ident[of "S@S'" δ] by auto
hence "range_vars δ ∩ bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}" using 4(1) * by blast
thus ?case using subst_img_comp_subset[of θ δ] 4(4) *** by blast
}
next
case (Equality S δ t t' a S' θ)
hence *: "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t (S@Equality a t t'#S')"
using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]]
unfolding range_vars_alt_def by fastforce
have "fv⇩s⇩t (S@S') ⊆ fv⇩s⇩t (S@Equality a t t'#S')" "vars⇩s⇩t (S@S') ⊆ vars⇩s⇩t (S@Equality a t t'#S')"
by auto
hence **: "fv⇩s⇩t (S@S' ⋅⇩s⇩t δ) ⊆ fv⇩s⇩t (S@Equality a t t'#S')"
"vars⇩s⇩t (S@S' ⋅⇩s⇩t δ) ⊆ vars⇩s⇩t (S@Equality a t t'#S')"
using subst_sends_strand_fv_to_img[of "S@S'" δ]
strand_subst_vars_union_bound[of "S@S'" δ] *
by blast+
have "wf⇩s⇩u⇩b⇩s⇩t δ" by (fact mgu_gives_wellformed_subst[OF Equality.hyps(2)[symmetric]])
{ case 1
have "bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = bvars⇩s⇩t (S@Equality a t t'#S')"
using bvars_subst_ident[of "S@S'" δ] by auto
thus ?case using 1 ** by blast
}
{ case 2
hence "subst_domain θ ∩ subst_domain δ = {}" "subst_domain θ ∩ range_vars δ = {}"
using * by blast+
thus ?case by (metis wf_subst_compose[OF ‹wf⇩s⇩u⇩b⇩s⇩t θ› ‹wf⇩s⇩u⇩b⇩s⇩t δ›])
}
{ case 3
hence "subst_domain θ ∩ vars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}" using ** by blast
moreover have "v ∈ fv⇩s⇩t (S@Equality a t t'#S')" when "v ∈ subst_domain δ" for v
using * that by blast
hence "subst_domain δ ∩ fv⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}"
using mgu_eliminates_dom[OF Equality.hyps(2)[symmetric],
THEN strand_fv_subst_subset_if_subst_elim, of _ "S@Equality a t t'#S'"]
unfolding subst_elim_def by auto
moreover have "bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = bvars⇩s⇩t (S@Equality a t t'#S')"
using bvars_subst_ident[of "S@S'" δ] by auto
hence "subst_domain δ ∩ bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}" using 3(1) * by blast
ultimately show ?case
using ** * subst_domain_compose[of θ δ] vars⇩s⇩t_is_fv⇩s⇩t_bvars⇩s⇩t[of "S@S' ⋅⇩s⇩t δ"]
by blast
}
{ case 4
have ***: "bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = bvars⇩s⇩t (S@Equality a t t'#S')"
using bvars_subst_ident[of "S@S'" δ] by auto
hence "range_vars δ ∩ bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}" using 4(1) * by blast
thus ?case using subst_img_comp_subset[of θ δ] 4(4) *** by blast
}
qed
private lemma LI_preserves_subst_wf:
assumes "(S⇩1,θ⇩1) ↝⇧* (S⇩2,θ⇩2)" "fv⇩s⇩t S⇩1 ∩ bvars⇩s⇩t S⇩1 = {}" "wf⇩s⇩u⇩b⇩s⇩t θ⇩1"
and "subst_domain θ⇩1 ∩ vars⇩s⇩t S⇩1 = {}" "range_vars θ⇩1 ∩ bvars⇩s⇩t S⇩1 = {}"
shows "fv⇩s⇩t S⇩2 ∩ bvars⇩s⇩t S⇩2 = {}" "wf⇩s⇩u⇩b⇩s⇩t θ⇩2"
and "subst_domain θ⇩2 ∩ vars⇩s⇩t S⇩2 = {}" "range_vars θ⇩2 ∩ bvars⇩s⇩t S⇩2 = {}"
using assms
proof (induction S⇩2 θ⇩2 rule: rtrancl_induct2)
case (step S⇩i θ⇩i S⇩j θ⇩j)
{ case 1 thus ?case using LI_preserves_subst_wf_single[OF ‹(S⇩i,θ⇩i) ↝ (S⇩j,θ⇩j)›] step.IH by metis }
{ case 2 thus ?case using LI_preserves_subst_wf_single[OF ‹(S⇩i,θ⇩i) ↝ (S⇩j,θ⇩j)›] step.IH by metis }
{ case 3 thus ?case using LI_preserves_subst_wf_single[OF ‹(S⇩i,θ⇩i) ↝ (S⇩j,θ⇩j)›] step.IH by metis }
{ case 4 thus ?case using LI_preserves_subst_wf_single[OF ‹(S⇩i,θ⇩i) ↝ (S⇩j,θ⇩j)›] step.IH by metis }
qed metis
lemma LI_preserves_wellformedness:
assumes "(S⇩1,θ⇩1) ↝⇧* (S⇩2,θ⇩2)" "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1"
shows "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩2 θ⇩2"
proof -
have *: "wf⇩s⇩t {} S⇩j"
when "(S⇩i, θ⇩i) ↝ (S⇩j, θ⇩j)" "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩i θ⇩i" for S⇩i θ⇩i S⇩j θ⇩j
using that
proof (induction rule: LI_rel.induct)
case (Unify S f U δ T S' θ)
have "fv (Fun f T) ∪ fv (Fun f U) ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')" using Unify.hyps(2) by force
hence "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')"
using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] by (metis subset_trans)
hence "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t (S@Send (Fun f T)#S') = {}"
using Unify.prems unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def by blast
thus ?case
using wf_unify[OF _ Unify.hyps(2) MGU_is_Unifier[OF mgu_gives_MGU], of "{}",
OF _ Unify.hyps(3)[symmetric], of S'] Unify.prems(1)
by (auto simp add: wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
next
case (Equality S δ t t' a S' θ)
have "fv t ∪ fv t' ⊆ fv⇩s⇩t (S@Equality a t t'#S')" using Equality.hyps(2) by force
hence "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t (S@Equality a t t'#S')"
using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by (metis subset_trans)
hence "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t (S@Equality a t t'#S') = {}"
using Equality.prems unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def by blast
thus ?case
using wf_equality[OF _ Equality.hyps(2)[symmetric], of "{}" S a S'] Equality.prems(1)
by (auto simp add: wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
qed (metis wf_send_compose wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
show ?thesis using assms
proof (induction rule: rtrancl_induct2)
case (step S⇩i θ⇩i S⇩j θ⇩j) thus ?case
using LI_preserves_subst_wf_single[OF ‹(S⇩i,θ⇩i) ↝ (S⇩j,θ⇩j)›] *[OF ‹(S⇩i,θ⇩i) ↝ (S⇩j,θ⇩j)›]
by (metis wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
qed simp
qed
lemma LI_preserves_trm_wf:
assumes "(S,θ) ↝⇧* (S',θ')" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)"
shows "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S')"
proof -
{ fix S θ S' θ'
assume "(S,θ) ↝ (S',θ')" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)"
hence "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S')"
proof (induction rule: LI_rel.induct)
case (Compose S T f S' θ)
hence "wf⇩t⇩r⇩m (Fun f T)"
and *: "t ∈ set S ⟹ wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p t)" "t ∈ set S' ⟹ wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p t)" for t
by auto
hence "wf⇩t⇩r⇩m t" when "t ∈ set T" for t using that unfolding wf⇩t⇩r⇩m_def by auto
hence "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p t)" when "t ∈ set (map Send T)" for t
using that unfolding wf⇩t⇩r⇩m_def by auto
thus ?case using * by force
next
case (Unify S f U δ T S' θ)
have "wf⇩t⇩r⇩m (Fun f T)" "wf⇩t⇩r⇩m (Fun f U)"
using Unify.prems(1) Unify.hyps(2) wf_trm_subterm[of _ "Fun f U"]
by (simp, force)
hence range_wf: "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using mgu_wf_trm[OF Unify.hyps(3)[symmetric]] by simp
{ fix s assume "s ∈ set (S@S' ⋅⇩s⇩t δ)"
hence "∃s' ∈ set (S@S'). s = s' ⋅⇩s⇩t⇩p δ ∧ wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s')"
using Unify.prems(1) by (auto simp add: subst_apply_strand_def)
moreover {
fix s' assume s': "s = s' ⋅⇩s⇩t⇩p δ" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s')" "s' ∈ set (S@S')"
from s'(2) have "trms⇩s⇩t⇩p (s' ⋅⇩s⇩t⇩p δ) = trms⇩s⇩t⇩p s' ⋅⇩s⇩e⇩t (rm_vars (set (bvars⇩s⇩t⇩p s')) δ)"
proof (induction s')
case (Inequality X F) thus ?case by (induct F) (auto simp add: subst_apply_pairs_def)
qed auto
hence "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s)"
using wf_trm_subst[OF wf_trms_subst_rm_vars'[OF range_wf]] ‹wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s')› s'(1)
by simp
}
ultimately have "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s)" by auto
}
thus ?case by auto
next
case (Equality S δ t t' a S' θ)
hence "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m t'" by simp_all
hence range_wf: "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using mgu_wf_trm[OF Equality.hyps(2)[symmetric]] by simp
{ fix s assume "s ∈ set (S@S' ⋅⇩s⇩t δ)"
hence "∃s' ∈ set (S@S'). s = s' ⋅⇩s⇩t⇩p δ ∧ wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s')"
using Equality.prems(1) by (auto simp add: subst_apply_strand_def)
moreover {
fix s' assume s': "s = s' ⋅⇩s⇩t⇩p δ" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s')" "s' ∈ set (S@S')"
from s'(2) have "trms⇩s⇩t⇩p (s' ⋅⇩s⇩t⇩p δ) = trms⇩s⇩t⇩p s' ⋅⇩s⇩e⇩t (rm_vars (set (bvars⇩s⇩t⇩p s')) δ)"
proof (induction s')
case (Inequality X F) thus ?case by (induct F) (auto simp add: subst_apply_pairs_def)
qed auto
hence "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s)"
using wf_trm_subst[OF wf_trms_subst_rm_vars'[OF range_wf]] ‹wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s')› s'(1)
by simp
}
ultimately have "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p s)" by auto
}
thus ?case by auto
qed
}
with assms show ?thesis by (induction rule: rtrancl_induct2) metis+
qed
end
subsection ‹Theorem: Soundness of the Lazy Intruder›
context
begin
private lemma LI_soundness_single:
assumes "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1" "(S⇩1,θ⇩1) ↝ (S⇩2,θ⇩2)" "ℐ ⊨⇩c ⟨S⇩2,θ⇩2⟩"
shows "ℐ ⊨⇩c ⟨S⇩1,θ⇩1⟩"
using assms(2,1,3)
proof (induction rule: LI_rel.induct)
case (Compose S T f S' θ)
hence *: "⟦{}; S⟧⇩c ℐ" "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; map Send T⟧⇩c ℐ" "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ"
unfolding constr_sem_c_def by force+
have "ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊢⇩c Fun f T ⋅ ℐ"
using *(2) Compose.hyps(2) ComposeC[OF _ Compose.hyps(3), of "map (λx. x ⋅ ℐ) T"]
unfolding subst_compose_def by force
thus "ℐ ⊨⇩c ⟨S@Send (Fun f T)#S',θ⟩"
using *(1,3) ‹ℐ ⊨⇩c ⟨S@map Send T@S',θ⟩›
by (auto simp add: constr_sem_c_def)
next
case (Unify S f U δ T S' θ)
have "(θ ∘⇩s δ) supports ℐ" "⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ"
using Unify.prems(2) unfolding constr_sem_c_def by metis+
then obtain σ where σ: "θ ∘⇩s δ ∘⇩s σ = ℐ" unfolding subst_compose_def by auto
have θfun_id: "Fun f U ⋅ θ = Fun f U" "Fun f T ⋅ θ = Fun f T"
using Unify.prems(1) trm_subst_ident[of "Fun f U" θ]
fv_subset_if_in_strand_ik[of "Fun f U" S] Unify.hyps(2)
fv_snd_rcv_strand_subset(2)[of S]
strand_vars_split(1)[of S "Send (Fun f T)#S'"]
unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def apply blast
using Unify.prems(1) trm_subst_ident[of "Fun f T" θ]
unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def by fastforce
hence θδ_disj:
"subst_domain θ ∩ subst_domain δ = {}"
"subst_domain θ ∩ range_vars δ = {}"
"subst_domain θ ∩ range_vars θ = {}"
using trm_subst_disj mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] apply (blast,blast)
using Unify.prems(1) unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def wf⇩s⇩u⇩b⇩s⇩t_def by blast
hence θδ_support: "θ supports ℐ" "δ supports ℐ"
by (simp_all add: subst_support_comp_split[OF ‹(θ ∘⇩s δ) supports ℐ›])
have "fv (Fun f T) ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')" "fv (Fun f U) ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')"
using Unify.hyps(2) by force+
hence δ_vars_bound: "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t (S@Send (Fun f T)#S')"
using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] by blast
have "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; [Send (Fun f T)]⟧⇩c ℐ"
proof -
from Unify.hyps(2) have "Fun f U ⋅ ℐ ∈ ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ" by blast
hence "Fun f U ⋅ ℐ ∈ ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ" by blast
moreover have "Unifier δ (Fun f T) (Fun f U)"
by (fact MGU_is_Unifier[OF mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]])
ultimately have "Fun f T ⋅ ℐ ∈ ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ"
using σ by (metis θfun_id subst_subst_compose)
thus ?thesis by simp
qed
have "⟦{}; S⟧⇩c ℐ" "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ"
proof -
have "(S@S' ⋅⇩s⇩t δ) ⋅⇩s⇩t θ = S@S' ⋅⇩s⇩t δ" "(S@S') ⋅⇩s⇩t θ = S@S'"
proof -
have "subst_domain θ ∩ vars⇩s⇩t (S@S') = {}"
using Unify.prems(1) by (auto simp add: wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
hence "subst_domain θ ∩ vars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}"
using θδ_disj(2) strand_subst_vars_union_bound[of "S@S'" δ] by blast
thus "(S@S' ⋅⇩s⇩t δ) ⋅⇩s⇩t θ = S@S' ⋅⇩s⇩t δ" "(S@S') ⋅⇩s⇩t θ = S@S'"
using strand_subst_comp ‹subst_domain θ ∩ vars⇩s⇩t (S@S') = {}› by (blast,blast)
qed
moreover have "subst_idem δ" by (fact mgu_gives_subst_idem[OF Unify.hyps(3)[symmetric]])
moreover have
"(subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t (S@S') = {}"
"(subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}"
"(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t (S@S') = {}"
using wf_constr_bvars_disj[OF Unify.prems(1)]
wf_constr_bvars_disj'[OF Unify.prems(1) δ_vars_bound]
by auto
ultimately have "⟦{}; S@S'⟧⇩c ℐ"
using ‹⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ› σ
strand_sem_subst(1)[of θ "S@S' ⋅⇩s⇩t δ" "{}" "δ ∘⇩s σ"]
strand_sem_subst(2)[of θ "S@S'" "{}" "δ ∘⇩s σ"]
strand_sem_subst_subst_idem[of δ "S@S'" "{}" σ]
unfolding constr_sem_c_def
by (metis subst_compose_assoc)
thus "⟦{}; S⟧⇩c ℐ" "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ" by auto
qed
show "ℐ ⊨⇩c ⟨S@Send (Fun f T)#S',θ⟩"
using θδ_support(1) ‹⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; [Send (Fun f T)]⟧⇩c ℐ› ‹⟦{}; S⟧⇩c ℐ› ‹⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ›
by (auto simp add: constr_sem_c_def)
next
case (Equality S δ t t' a S' θ)
have "(θ ∘⇩s δ) supports ℐ" "⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ"
using Equality.prems(2) unfolding constr_sem_c_def by metis+
then obtain σ where σ: "θ ∘⇩s δ ∘⇩s σ = ℐ" unfolding subst_compose_def by auto
have "fv t ⊆ vars⇩s⇩t (S@Equality a t t'#S')" "fv t' ⊆ vars⇩s⇩t (S@Equality a t t'#S')"
by auto
moreover have "subst_domain θ ∩ vars⇩s⇩t (S@Equality a t t'#S') = {}"
using Equality.prems(1) unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def by auto
ultimately have θfun_id: "t ⋅ θ = t" "t' ⋅ θ = t'"
using trm_subst_ident[of t θ] trm_subst_ident[of t' θ]
by auto
hence θδ_disj:
"subst_domain θ ∩ subst_domain δ = {}"
"subst_domain θ ∩ range_vars δ = {}"
"subst_domain θ ∩ range_vars θ = {}"
using trm_subst_disj mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] apply (blast,blast)
using Equality.prems(1) unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def wf⇩s⇩u⇩b⇩s⇩t_def by blast
hence θδ_support: "θ supports ℐ" "δ supports ℐ"
by (simp_all add: subst_support_comp_split[OF ‹(θ ∘⇩s δ) supports ℐ›])
have "fv t ⊆ fv⇩s⇩t (S@Equality a t t'#S')" "fv t' ⊆ fv⇩s⇩t (S@Equality a t t'#S')" by auto
hence δ_vars_bound: "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t (S@Equality a t t'#S')"
using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by blast
have "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; [Equality a t t']⟧⇩c ℐ"
proof -
have "t ⋅ δ = t' ⋅ δ"
using MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
by metis
hence "t ⋅ (θ ∘⇩s δ) = t' ⋅ (θ ∘⇩s δ)" by (metis θfun_id subst_subst_compose)
hence "t ⋅ ℐ = t' ⋅ ℐ" by (metis σ subst_subst_compose)
thus ?thesis by simp
qed
have "⟦{}; S⟧⇩c ℐ" "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ"
proof -
have "(S@S' ⋅⇩s⇩t δ) ⋅⇩s⇩t θ = S@S' ⋅⇩s⇩t δ" "(S@S') ⋅⇩s⇩t θ = S@S'"
proof -
have "subst_domain θ ∩ vars⇩s⇩t (S@S') = {}"
using Equality.prems(1)
by (fastforce simp add: wf⇩c⇩o⇩n⇩s⇩t⇩r_def simp del: subst_range.simps)
hence "subst_domain θ ∩ fv⇩s⇩t (S@S') = {}" by blast
hence "subst_domain θ ∩ fv⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}"
using θδ_disj(2) subst_sends_strand_fv_to_img[of "S@S'" δ] by blast
thus "(S@S' ⋅⇩s⇩t δ) ⋅⇩s⇩t θ = S@S' ⋅⇩s⇩t δ" "(S@S') ⋅⇩s⇩t θ = S@S'"
using strand_subst_comp ‹subst_domain θ ∩ vars⇩s⇩t (S@S') = {}› by (blast,blast)
qed
moreover have
"(subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t (S@S') = {}"
"(subst_domain θ ∪ range_vars θ) ∩ bvars⇩s⇩t (S@S' ⋅⇩s⇩t δ) = {}"
"(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩t (S@S') = {}"
using wf_constr_bvars_disj[OF Equality.prems(1)]
wf_constr_bvars_disj'[OF Equality.prems(1) δ_vars_bound]
by auto
ultimately have "⟦{}; S@S'⟧⇩c ℐ"
using ‹⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ› σ
strand_sem_subst(1)[of θ "S@S' ⋅⇩s⇩t δ" "{}" "δ ∘⇩s σ"]
strand_sem_subst(2)[of θ "S@S'" "{}" "δ ∘⇩s σ"]
strand_sem_subst_subst_idem[of δ "S@S'" "{}" σ]
mgu_gives_subst_idem[OF Equality.hyps(2)[symmetric]]
unfolding constr_sem_c_def
by (metis subst_compose_assoc)
thus "⟦{}; S⟧⇩c ℐ" "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ" by auto
qed
show "ℐ ⊨⇩c ⟨S@Equality a t t'#S',θ⟩"
using θδ_support(1) ‹⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; [Equality a t t']⟧⇩c ℐ› ‹⟦{}; S⟧⇩c ℐ› ‹⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ›
by (auto simp add: constr_sem_c_def)
qed
theorem LI_soundness:
assumes "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1" "(S⇩1,θ⇩1) ↝⇧* (S⇩2,θ⇩2)" "ℐ ⊨⇩c ⟨S⇩2, θ⇩2⟩"
shows "ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩"
using assms(2,1,3)
proof (induction S⇩2 θ⇩2 rule: rtrancl_induct2)
case (step S⇩i θ⇩i S⇩j θ⇩j) thus ?case
using LI_preserves_wellformedness[OF ‹(S⇩1, θ⇩1) ↝⇧* (S⇩i, θ⇩i)› ‹wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1›]
LI_soundness_single[OF _ ‹(S⇩i, θ⇩i) ↝ (S⇩j, θ⇩j)› ‹ℐ ⊨⇩c ⟨S⇩j, θ⇩j⟩›]
step.IH[OF ‹wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1›]
by metis
qed metis
end
subsection ‹Theorem: Completeness of the Lazy Intruder›
context
begin
private lemma LI_completeness_single:
assumes "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1" "ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩" "¬simple S⇩1"
shows "∃S⇩2 θ⇩2. (S⇩1,θ⇩1) ↝ (S⇩2,θ⇩2) ∧ (ℐ ⊨⇩c ⟨S⇩2, θ⇩2⟩)"
using not_simple_elim[OF ‹¬simple S⇩1›]
proof -
{
assume "∃S' S'' a t t'. S⇩1 = S'@Equality a t t'#S'' ∧ simple S'"
then obtain S a t t' S' where S⇩1: "S⇩1 = S@Equality a t t'#S'" "simple S" by moura
hence *: "wf⇩s⇩t {} S" "ℐ ⊨⇩c ⟨S, θ⇩1⟩" "θ⇩1 supports ℐ" "t ⋅ ℐ = t' ⋅ ℐ"
using ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩› ‹wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1› wf_eq_fv[of "{}" S t t' S']
fv_snd_rcv_strand_subset(5)[of S]
by (auto simp add: constr_sem_c_def wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
from * have "Unifier ℐ t t'" by simp
then obtain δ where δ:
"Some δ = mgu t t'" "subst_idem δ" "subst_domain δ ∪ range_vars δ ⊆ fv t ∪ fv t'"
using mgu_always_unifies mgu_gives_subst_idem mgu_vars_bounded by metis+
have "δ ≼⇩∘ ℐ"
using mgu_gives_MGU[OF δ(1)[symmetric]]
by (metis ‹Unifier ℐ t t'›)
hence "δ supports ℐ" using subst_support_if_mgt_subst_idem[OF _ δ(2)] by metis
hence "(θ⇩1 ∘⇩s δ) supports ℐ" using subst_support_comp ‹θ⇩1 supports ℐ› by metis
have "⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ"
proof -
have "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t S⇩1" using δ(3) S⇩1(1) by auto
hence "⟦{}; S⇩1 ⋅⇩s⇩t δ⟧⇩c ℐ"
using ‹subst_idem δ› ‹δ ≼⇩∘ ℐ› ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩› strand_sem_subst
wf_constr_bvars_disj'(1)[OF assms(1)]
unfolding subst_idem_def constr_sem_c_def
by (metis (no_types) subst_compose_assoc)
thus "⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ" using S⇩1(1) by force
qed
moreover have "(S@Equality a t t'#S', θ⇩1) ↝ (S@S' ⋅⇩s⇩t δ, θ⇩1 ∘⇩s δ)"
using LI_rel.Equality[OF ‹simple S› δ(1)] S⇩1 by metis
ultimately have ?thesis
using S⇩1(1) ‹(θ⇩1 ∘⇩s δ) supports ℐ›
by (auto simp add: constr_sem_c_def)
} moreover {
assume "∃S' S'' f T. S⇩1 = S'@Send (Fun f T)#S'' ∧ simple S'"
with assms obtain S f T S' where S⇩1: "S⇩1 = S@Send (Fun f T)#S'" "simple S" by moura
hence "wf⇩s⇩t {} S" "ℐ ⊨⇩c ⟨S, θ⇩1⟩" "θ⇩1 supports ℐ"
using ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩› ‹wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1›
by (auto simp add: constr_sem_c_def wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
have fun_sat: "ℐ ⊨⇩c ⟨S@(map Send T)@S', θ⇩1⟩" when T: "⋀t. t ∈ set T ⟹ ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ"
proof -
have "⋀t. t ∈ set T ⟹ ⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; [Send t]⟧⇩c ℐ" using T by simp
hence "⟦ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ; map Send T⟧⇩c ℐ" using ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩› strand_sem_Send_map by metis
moreover have "⟦ik⇩s⇩t (S@(map Send T)) ⋅⇩s⇩e⇩t ℐ; S'⟧⇩c ℐ"
using ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩› S⇩1
by (auto simp add: constr_sem_c_def)
ultimately show ?thesis
using ‹ℐ ⊨⇩c ⟨S, θ⇩1⟩› ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩›
by (force simp add: constr_sem_c_def)
qed
from S⇩1 ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩› have "ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊢⇩c Fun f T ⋅ ℐ" by (auto simp add: constr_sem_c_def)
hence ?thesis
proof cases
case AxiomC
hence ex_t: "∃t. t ∈ ik⇩s⇩t S ∧ Fun f T ⋅ ℐ = t ⋅ ℐ" by auto
show ?thesis
proof (cases "∀T'. Fun f T' ∈ ik⇩s⇩t S ⟶ Fun f T ⋅ ℐ ≠ Fun f T' ⋅ ℐ")
case True
have "∃v. Var v ∈ ik⇩s⇩t S ∧ Fun f T ⋅ ℐ = ℐ v"
proof -
obtain t where "t ∈ ik⇩s⇩t S" "Fun f T ⋅ ℐ = t ⋅ ℐ" using ex_t by moura
thus ?thesis
using ‹∀T'. Fun f T' ∈ ik⇩s⇩t S ⟶ Fun f T ⋅ ℐ ≠ Fun f T' ⋅ ℐ›
by (cases t) auto
qed
hence "∃v ∈ wfrestrictedvars⇩s⇩t S. Fun f T ⋅ ℐ = ℐ v"
using vars_subset_if_in_strand_ik2[of _ S] by fastforce
then obtain v S⇩p⇩r⇩e S⇩s⇩u⇩f
where S: "S = S⇩p⇩r⇩e@Send (Var v)#S⇩s⇩u⇩f" "Fun f T ⋅ ℐ = ℐ v"
"¬(∃w ∈ wfrestrictedvars⇩s⇩t S⇩p⇩r⇩e. Fun f T ⋅ ℐ = ℐ w)"
using ‹wf⇩s⇩t {} S› wf_simple_strand_first_Send_var_split[OF _ ‹simple S›, of "Fun f T" ℐ]
by auto
hence "∀w. Var w ∈ ik⇩s⇩t S⇩p⇩r⇩e ⟶ ℐ v ≠ Var w ⋅ ℐ" by auto
moreover have "∀T'. Fun f T' ∈ ik⇩s⇩t S⇩p⇩r⇩e ⟶ Fun f T ⋅ ℐ ≠ Fun f T' ⋅ ℐ"
using ‹∀T'. Fun f T' ∈ ik⇩s⇩t S ⟶ Fun f T ⋅ ℐ ≠ Fun f T' ⋅ ℐ› S(1)
by (meson contra_subsetD ik_append_subset(1))
hence "∀g T'. Fun g T' ∈ ik⇩s⇩t S⇩p⇩r⇩e ⟶ ℐ v ≠ Fun g T' ⋅ ℐ" using S(2) by simp
ultimately have "∀t ∈ ik⇩s⇩t S⇩p⇩r⇩e. ℐ v ≠ t ⋅ ℐ" by (metis term.exhaust)
hence "ℐ v ∉ (ik⇩s⇩t S⇩p⇩r⇩e) ⋅⇩s⇩e⇩t ℐ" by auto
have "ik⇩s⇩t S⇩p⇩r⇩e ⋅⇩s⇩e⇩t ℐ ⊢⇩c ℐ v"
using S⇩1(1) S(1) ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩›
by (auto simp add: constr_sem_c_def)
hence "ik⇩s⇩t S⇩p⇩r⇩e ⋅⇩s⇩e⇩t ℐ ⊢⇩c Fun f T ⋅ ℐ" using ‹Fun f T ⋅ ℐ = ℐ v› by metis
hence "length T = arity f" "public f" "⋀t. t ∈ set T ⟹ ik⇩s⇩t S⇩p⇩r⇩e ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ"
using ‹Fun f T ⋅ ℐ = ℐ v› ‹ℐ v ∉ ik⇩s⇩t S⇩p⇩r⇩e ⋅⇩s⇩e⇩t ℐ›
intruder_synth.simps[of "ik⇩s⇩t S⇩p⇩r⇩e ⋅⇩s⇩e⇩t ℐ" "ℐ v"]
by auto
hence *: "⋀t. t ∈ set T ⟹ ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ"
using S(1) by (auto intro: ideduct_synth_mono)
hence "ℐ ⊨⇩c ⟨S@(map Send T)@S', θ⇩1⟩" by (metis fun_sat)
moreover have "(S@Send (Fun f T)#S', θ⇩1) ↝ (S@map Send T@S', θ⇩1)"
by (metis LI_rel.Compose[OF ‹simple S› ‹length T = arity f› ‹public f›])
ultimately show ?thesis using S⇩1 by auto
next
case False
then obtain T' where t: "Fun f T' ∈ ik⇩s⇩t S" "Fun f T ⋅ ℐ = Fun f T' ⋅ ℐ"
by auto
hence "fv (Fun f T') ⊆ fv⇩s⇩t S⇩1"
using S⇩1(1) fv_subset_if_in_strand_ik'[OF t(1)]
fv_snd_rcv_strand_subset(2)[of S]
by auto
from t have "Unifier ℐ (Fun f T) (Fun f T')" by simp
then obtain δ where δ:
"Some δ = mgu (Fun f T) (Fun f T')" "subst_idem δ"
"subst_domain δ ∪ range_vars δ ⊆ fv (Fun f T) ∪ fv (Fun f T')"
using mgu_always_unifies mgu_gives_subst_idem mgu_vars_bounded by metis+
have "δ ≼⇩∘ ℐ"
using mgu_gives_MGU[OF δ(1)[symmetric]]
by (metis ‹Unifier ℐ (Fun f T) (Fun f T')›)
hence "δ supports ℐ" using subst_support_if_mgt_subst_idem[OF _ δ(2)] by metis
hence "(θ⇩1 ∘⇩s δ) supports ℐ" using subst_support_comp ‹θ⇩1 supports ℐ› by metis
have "⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ"
proof -
have "subst_domain δ ∪ range_vars δ ⊆ fv⇩s⇩t S⇩1"
using δ(3) S⇩1(1) ‹fv (Fun f T') ⊆ fv⇩s⇩t S⇩1›
unfolding range_vars_alt_def by (fastforce simp del: subst_range.simps)
hence "⟦{}; S⇩1 ⋅⇩s⇩t δ⟧⇩c ℐ"
using ‹subst_idem δ› ‹δ ≼⇩∘ ℐ› ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩› strand_sem_subst
wf_constr_bvars_disj'(1)[OF assms(1)]
unfolding subst_idem_def constr_sem_c_def
by (metis (no_types) subst_compose_assoc)
thus "⟦{}; S@S' ⋅⇩s⇩t δ⟧⇩c ℐ" using S⇩1(1) by force
qed
moreover have "(S@Send (Fun f T)#S', θ⇩1) ↝ (S@S' ⋅⇩s⇩t δ, θ⇩1 ∘⇩s δ)"
using LI_rel.Unify[OF ‹simple S› t(1) δ(1)] S⇩1 by metis
ultimately show ?thesis
using S⇩1(1) ‹(θ⇩1 ∘⇩s δ) supports ℐ›
by (auto simp add: constr_sem_c_def)
qed
next
case (ComposeC T' g)
hence "f = g" "length T = arity f" "public f"
and "⋀x. x ∈ set T ⟹ ik⇩s⇩t S ⋅⇩s⇩e⇩t ℐ ⊢⇩c x ⋅ ℐ"
by auto
hence "ℐ ⊨⇩c ⟨S@(map Send T)@S', θ⇩1⟩" using fun_sat by metis
moreover have "(S⇩1, θ⇩1) ↝ (S@(map Send T)@S', θ⇩1)"
using S⇩1 LI_rel.Compose[OF ‹simple S› ‹length T = arity f› ‹public f›]
by metis
ultimately show ?thesis by metis
qed
} moreover have "⋀A B X F. S⇩1 = A@Inequality X F#B ⟹ ineq_model ℐ X F"
using assms(2) by (auto simp add: constr_sem_c_def)
ultimately show ?thesis using not_simple_elim[OF ‹¬simple S⇩1›] by metis
qed
theorem LI_completeness:
assumes "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1" "ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩"
shows "∃S⇩2 θ⇩2. (S⇩1,θ⇩1) ↝⇧* (S⇩2,θ⇩2) ∧ simple S⇩2 ∧ (ℐ ⊨⇩c ⟨S⇩2, θ⇩2⟩)"
proof (cases "simple S⇩1")
case False
let ?Stuck = "λS⇩2 θ⇩2. ¬(∃S⇩3 θ⇩3. (S⇩2,θ⇩2) ↝ (S⇩3,θ⇩3) ∧ (ℐ ⊨⇩c ⟨S⇩3, θ⇩3⟩))"
let ?Sats = "{((S,θ),(S',θ')). (S,θ) ↝ (S',θ') ∧ (ℐ ⊨⇩c ⟨S, θ⟩) ∧ (ℐ ⊨⇩c ⟨S', θ'⟩)}"
have simple_if_stuck:
"⋀S⇩2 θ⇩2. ⟦(S⇩1,θ⇩1) ↝⇧+ (S⇩2,θ⇩2); ℐ ⊨⇩c ⟨S⇩2, θ⇩2⟩; ?Stuck S⇩2 θ⇩2⟧ ⟹ simple S⇩2"
using LI_completeness_single
LI_preserves_wellformedness
‹wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1›
trancl_into_rtrancl
by metis
have base: "∃b. ((S⇩1,θ⇩1),b) ∈ ?Sats"
using LI_completeness_single[OF assms False] assms(2)
by auto
have *: "⋀S θ S' θ'. ((S,θ),(S',θ')) ∈ ?Sats⇧+ ⟹ (S,θ) ↝⇧+ (S',θ') ∧ (ℐ ⊨⇩c ⟨S', θ'⟩)"
proof -
fix S θ S' θ'
assume "((S,θ),(S',θ')) ∈ ?Sats⇧+"
thus "(S,θ) ↝⇧+ (S',θ') ∧ (ℐ ⊨⇩c ⟨S', θ'⟩)"
by (induct rule: trancl_induct2) auto
qed
have "∃S⇩2 θ⇩2. ((S⇩1,θ⇩1),(S⇩2,θ⇩2)) ∈ ?Sats⇧+ ∧ ?Stuck S⇩2 θ⇩2"
proof (rule ccontr)
assume "¬(∃S⇩2 θ⇩2. ((S⇩1,θ⇩1),(S⇩2,θ⇩2)) ∈ ?Sats⇧+ ∧ ?Stuck S⇩2 θ⇩2)"
hence sat_not_stuck: "⋀S⇩2 θ⇩2. ((S⇩1,θ⇩1),(S⇩2,θ⇩2)) ∈ ?Sats⇧+ ⟹ ¬?Stuck S⇩2 θ⇩2" by blast
have "∀S θ. ((S⇩1,θ⇩1),(S,θ)) ∈ ?Sats⇧+ ⟶ (∃b. ((S,θ),b) ∈ ?Sats)"
proof (intro allI impI)
fix S θ assume a: "((S⇩1,θ⇩1),(S,θ)) ∈ ?Sats⇧+"
have "⋀b. ((S⇩1,θ⇩1),b) ∈ ?Sats⇧+ ⟹ ∃c. b ↝ c ∧ ((S⇩1,θ⇩1),c) ∈ ?Sats⇧+"
proof -
fix b assume in_sat: "((S⇩1,θ⇩1),b) ∈ ?Sats⇧+"
hence "∃c. (b,c) ∈ ?Sats" using * sat_not_stuck by (cases b) blast
thus "∃c. b ↝ c ∧ ((S⇩1,θ⇩1),c) ∈ ?Sats⇧+"
using trancl_into_trancl[OF in_sat] by blast
qed
hence "∃S' θ'. (S,θ) ↝ (S',θ') ∧ ((S⇩1,θ⇩1),(S',θ')) ∈ ?Sats⇧+" using a by auto
then obtain S' θ' where S'θ': "(S,θ) ↝ (S',θ')" "((S⇩1,θ⇩1),(S',θ')) ∈ ?Sats⇧+" by auto
hence "ℐ ⊨⇩c ⟨S', θ'⟩" using * by blast
moreover have "(S⇩1, θ⇩1) ↝⇧+ (S,θ)" using a trancl_mono by blast
ultimately have "((S,θ),(S',θ')) ∈ ?Sats" using S'θ'(1) * a by blast
thus "∃b. ((S,θ),b) ∈ ?Sats" using S'θ'(2) by blast
qed
hence "∃f. ∀i::nat. (f i, f (Suc i)) ∈ ?Sats"
using infinite_chain_intro'[OF base] by blast
moreover have "?Sats ⊆ LI_rel⇧+" by auto
hence "¬(∃f. ∀i::nat. (f i, f (Suc i)) ∈ ?Sats)"
using LI_no_infinite_chain infinite_chain_mono by blast
ultimately show False by auto
qed
hence "∃S⇩2 θ⇩2. (S⇩1, θ⇩1) ↝⇧+ (S⇩2, θ⇩2) ∧ simple S⇩2 ∧ (ℐ ⊨⇩c ⟨S⇩2, θ⇩2⟩)"
using simple_if_stuck * by blast
thus ?thesis by (meson trancl_into_rtrancl)
qed (blast intro: ‹ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩›)
end
subsection ‹Corollary: Soundness and Completeness as a Single Theorem›
corollary LI_soundness_and_completeness:
assumes "wf⇩c⇩o⇩n⇩s⇩t⇩r S⇩1 θ⇩1"
shows "ℐ ⊨⇩c ⟨S⇩1, θ⇩1⟩ ⟷ (∃S⇩2 θ⇩2. (S⇩1,θ⇩1) ↝⇧* (S⇩2,θ⇩2) ∧ simple S⇩2 ∧ (ℐ ⊨⇩c ⟨S⇩2, θ⇩2⟩))"
by (metis LI_soundness[OF assms] LI_completeness[OF assms])
end
end
Theory Typed_Model
section ‹The Typed Model›
theory Typed_Model
imports Lazy_Intruder
begin
text ‹Term types›
type_synonym ('f,'v) term_type = "('f,'v) term"
text ‹Constructors for term types›
abbreviation (input) TAtom::"'v ⇒ ('f,'v) term_type" where
"TAtom a ≡ Var a"
abbreviation (input) TComp::"['f, ('f,'v) term_type list] ⇒ ('f,'v) term_type" where
"TComp f T ≡ Fun f T"
text ‹
The typed model extends the intruder model with a typing function ‹Γ› that assigns types to terms.
›
locale typed_model = intruder_model arity public Ana
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,'var) term ⇒ (('fun,'var) term list × ('fun,'var) term list)"
+
fixes Γ::"('fun,'var) term ⇒ ('fun,'atom::finite) term_type"
assumes const_type: "⋀c. arity c = 0 ⟹ ∃a. ∀T. Γ (Fun c T) = TAtom a"
and fun_type: "⋀f T. arity f > 0 ⟹ Γ (Fun f T) = TComp f (map Γ T)"
and infinite_typed_consts: "⋀a. infinite {c. Γ (Fun c []) = TAtom a ∧ public c}"
and Γ_wf: "⋀t f T. TComp f T ⊑ Γ t ⟹ arity f > 0"
"⋀x. wf⇩t⇩r⇩m (Γ (Var x))"
and no_private_funs[simp]: "⋀f. arity f > 0 ⟹ public f"
begin
subsection ‹Definitions›
text ‹The set of atomic types›
abbreviation "𝔗⇩a ≡ UNIV::('atom set)"
text ‹Well-typed substitutions›
definition wt⇩s⇩u⇩b⇩s⇩t where
"wt⇩s⇩u⇩b⇩s⇩t σ ≡ (∀v. Γ (Var v) = Γ (σ v))"
text ‹The set of sub-message patterns (SMP)›
inductive_set SMP::"('fun,'var) terms ⇒ ('fun,'var) terms" for M where
MP[intro]: "t ∈ M ⟹ t ∈ SMP M"
| Subterm[intro]: "⟦t ∈ SMP M; t' ⊑ t⟧ ⟹ t' ∈ SMP M"
| Substitution[intro]: "⟦t ∈ SMP M; wt⇩s⇩u⇩b⇩s⇩t δ; wf⇩t⇩r⇩m⇩s (subst_range δ)⟧ ⟹ (t ⋅ δ) ∈ SMP M"
| Ana[intro]: "⟦t ∈ SMP M; Ana t = (K,T); k ∈ set K⟧ ⟹ k ∈ SMP M"
text ‹
Type-flaw resistance for sets:
Unifiable sub-message patterns must have the same type (unless they are variables)
›
definition tfr⇩s⇩e⇩t where
"tfr⇩s⇩e⇩t M ≡ (∀s ∈ SMP M - (Var`𝒱). ∀t ∈ SMP M - (Var`𝒱). (∃δ. Unifier δ s t) ⟶ Γ s = Γ t)"
text ‹
Type-flaw resistance for strand steps:
- The terms in a satisfiable equality step must have the same types
- Inequality steps must satisfy the conditions of the "inequality lemma"›
fun tfr⇩s⇩t⇩p where
"tfr⇩s⇩t⇩p (Equality a t t') = ((∃δ. Unifier δ t t') ⟶ Γ t = Γ t')"
| "tfr⇩s⇩t⇩p (Inequality X F) = (
(∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. ∃a. Γ (Var x) = TAtom a) ∨
(∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X)))"
| "tfr⇩s⇩t⇩p _ = True"
text ‹
Type-flaw resistance for strands:
- The set of terms in strands must be type-flaw resistant
- The steps of strands must be type-flaw resistant
›
definition tfr⇩s⇩t where
"tfr⇩s⇩t S ≡ tfr⇩s⇩e⇩t (trms⇩s⇩t S) ∧ list_all tfr⇩s⇩t⇩p S"
subsection ‹Small Lemmata›
lemma tfr⇩s⇩t⇩p_list_all_alt_def:
"list_all tfr⇩s⇩t⇩p S ⟷
((∀a t t'. Equality a t t' ∈ set S ∧ (∃δ. Unifier δ t t') ⟶ Γ t = Γ t') ∧
(∀X F. Inequality X F ∈ set S ⟶
(∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. ∃a. Γ (Var x) = TAtom a)
∨ (∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))))"
(is "?P S ⟷ ?Q S")
proof
show "?P S ⟹ ?Q S"
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
show "?Q S ⟹ ?P S"
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
qed
lemma Γ_wf': "wf⇩t⇩r⇩m t ⟹ wf⇩t⇩r⇩m (Γ t)"
proof (induction t)
case (Fun f T)
hence *: "arity f = length T" "⋀t. t ∈ set T ⟹ wf⇩t⇩r⇩m (Γ t)" unfolding wf⇩t⇩r⇩m_def by auto
{ assume "arity f = 0" hence ?case using const_type[of f] by auto }
moreover
{ assume "arity f > 0" hence ?case using fun_type[of f] * by force }
ultimately show ?case by auto
qed (metis Γ_wf(2))
lemma fun_type_inv: assumes "Γ t = TComp f T" shows "arity f > 0" "public f"
using Γ_wf(1)[of f T t] assms by simp_all
lemma fun_type_inv_wf: assumes "Γ t = TComp f T" "wf⇩t⇩r⇩m t" shows "arity f = length T"
using Γ_wf'[OF assms(2)] assms(1) unfolding wf⇩t⇩r⇩m_def by auto
lemma const_type_inv: "Γ (Fun c X) = TAtom a ⟹ arity c = 0"
by (rule ccontr, simp add: fun_type)
lemma const_type_inv_wf: assumes "Γ (Fun c X) = TAtom a" and "wf⇩t⇩r⇩m (Fun c X)" shows "X = []"
by (metis assms const_type_inv length_0_conv subtermeqI' wf⇩t⇩r⇩m_def)
lemma const_type': "∀c ∈ 𝒞. ∃a ∈ 𝔗⇩a. ∀X. Γ (Fun c X) = TAtom a" using const_type by simp
lemma fun_type': "∀f ∈ Σ⇩f. ∀X. Γ (Fun f X) = TComp f (map Γ X)" using fun_type by simp
lemma infinite_public_consts[simp]: "infinite {c. public c ∧ arity c = 0}"
proof -
fix a::'atom
define A where "A ≡ {c. Γ (Fun c []) = TAtom a ∧ public c}"
define B where "B ≡ {c. public c ∧ arity c = 0}"
have "arity c = 0" when c: "c ∈ A" for c
using c const_type_inv unfolding A_def by blast
hence "A ⊆ B" unfolding A_def B_def by blast
hence "infinite B"
using infinite_typed_consts[of a, unfolded A_def[symmetric]]
by (metis infinite_super)
thus ?thesis unfolding B_def by blast
qed
lemma infinite_fun_syms[simp]:
"infinite {c. public c ∧ arity c > 0} ⟹ infinite Σ⇩f"
"infinite 𝒞" "infinite 𝒞⇩p⇩u⇩b" "infinite (UNIV::'fun set)"
by (metis Σ⇩f_unfold finite_Collect_conjI,
metis infinite_public_consts finite_Collect_conjI,
use infinite_public_consts 𝒞pub_unfold in ‹force simp add: Collect_conj_eq›,
metis UNIV_I finite_subset subsetI infinite_public_consts(1))
lemma id_univ_proper_subset[simp]: "Σ⇩f ⊂ UNIV" "(∃f. arity f > 0) ⟹ 𝒞 ⊂ UNIV"
by (metis finite.emptyI inf_top.right_neutral top.not_eq_extremum disjoint_fun_syms
infinite_fun_syms(2) inf_commute)
(metis top.not_eq_extremum UNIV_I const_arity_eq_zero less_irrefl)
lemma exists_fun_notin_funs_term: "∃f::'fun. f ∉ funs_term t"
by (metis UNIV_eq_I finite_fun_symbols infinite_fun_syms(4))
lemma exists_fun_notin_funs_terms:
assumes "finite M" shows "∃f::'fun. f ∉ ⋃(funs_term ` M)"
by (metis assms finite_fun_symbols infinite_fun_syms(4) ex_new_if_finite finite_UN)
lemma exists_notin_funs⇩s⇩t: "∃f. f ∉ funs⇩s⇩t (S::('fun,'var) strand)"
by (metis UNIV_eq_I finite_funs⇩s⇩t infinite_fun_syms(4))
lemma infinite_typed_consts': "infinite {c. Γ (Fun c []) = TAtom a ∧ public c ∧ arity c = 0}"
proof -
{ fix c assume "Γ (Fun c []) = TAtom a" "public c"
hence "arity c = 0" using const_type[of c] fun_type[of c "[]"] by auto
} hence "{c. Γ (Fun c []) = TAtom a ∧ public c ∧ arity c = 0} =
{c. Γ (Fun c []) = TAtom a ∧ public c}"
by auto
thus "infinite {c. Γ (Fun c []) = TAtom a ∧ public c ∧ arity c = 0}"
using infinite_typed_consts[of a] by metis
qed
lemma atypes_inhabited: "∃c. Γ (Fun c []) = TAtom a ∧ wf⇩t⇩r⇩m (Fun c []) ∧ public c ∧ arity c = 0"
proof -
obtain c where "Γ (Fun c []) = TAtom a" "public c" "arity c = 0"
using infinite_typed_consts'(1)[of a] not_finite_existsD by blast
thus ?thesis using const_type_inv[OF ‹Γ (Fun c []) = TAtom a›] unfolding wf⇩t⇩r⇩m_def by auto
qed
lemma atype_ground_term_ex: "∃t. fv t = {} ∧ Γ t = TAtom a ∧ wf⇩t⇩r⇩m t"
using atypes_inhabited[of a] by force
lemma fun_type_id_eq: "Γ (Fun f X) = TComp g Y ⟹ f = g"
by (metis const_type fun_type neq0_conv "term.inject"(2) "term.simps"(4))
lemma fun_type_length_eq: "Γ (Fun f X) = TComp g Y ⟹ length X = length Y"
by (metis fun_type fun_type_id_eq fun_type_inv(1) length_map term.inject(2))
lemma type_ground_inhabited: "∃t'. fv t' = {} ∧ Γ t = Γ t'"
proof -
{ fix τ::"('fun, 'atom) term_type" assume "⋀f T. Fun f T ⊑ τ ⟹ 0 < arity f"
hence "∃t'. fv t' = {} ∧ τ = Γ t'"
proof (induction τ)
case (Fun f T)
hence "arity f > 0" by auto
from Fun.IH Fun.prems(1) have "∃Y. map Γ Y = T ∧ (∀x ∈ set Y. fv x = {})"
proof (induction T)
case (Cons x X)
hence "⋀g Y. Fun g Y ⊑ Fun f X ⟹ 0 < arity g" by auto
hence "∃Y. map Γ Y = X ∧ (∀x∈set Y. fv x = {})" using Cons by auto
moreover have "∃t'. fv t' = {} ∧ x = Γ t'" using Cons by auto
ultimately obtain y Y where
"fv y = {}" "Γ y = x" "map Γ Y = X" "∀x∈set Y. fv x = {}"
using Cons by moura
hence "map Γ (y#Y) = x#X ∧ (∀x∈set (y#Y). fv x = {})" by auto
thus ?case by meson
qed simp
then obtain Y where "map Γ Y = T" "∀x ∈ set Y. fv x = {}" by metis
hence "fv (Fun f Y) = {}" "Γ (Fun f Y) = TComp f T" using fun_type[OF ‹arity f > 0›] by auto
thus ?case by (metis exI[of "λt. fv t = {} ∧ Γ t = TComp f T" "Fun f Y"])
qed (metis atype_ground_term_ex)
}
thus ?thesis by (metis Γ_wf(1))
qed
lemma type_wfttype_inhabited:
assumes "⋀f T. Fun f T ⊑ τ ⟹ 0 < arity f" "wf⇩t⇩r⇩m τ"
shows "∃t. Γ t = τ ∧ wf⇩t⇩r⇩m t"
using assms
proof (induction τ)
case (Fun f Y)
have IH: "∃t. Γ t = y ∧ wf⇩t⇩r⇩m t" when y: "y ∈ set Y " for y
proof -
have "wf⇩t⇩r⇩m y"
using Fun y unfolding wf⇩t⇩r⇩m_def
by (metis Fun_param_is_subterm term.le_less_trans)
moreover have "Fun g Z ⊑ y ⟹ 0 < arity g" for g Z
using Fun y by auto
ultimately show ?thesis using Fun.IH[OF y] by auto
qed
from Fun have "arity f = length Y" "arity f > 0" unfolding wf⇩t⇩r⇩m_def by force+
moreover from IH have "∃X. map Γ X = Y ∧ (∀x ∈ set X. wf⇩t⇩r⇩m x)"
by (induct Y, simp_all, metis list.simps(9) set_ConsD)
ultimately show ?case by (metis fun_type length_map wf_trmI)
qed (use atypes_inhabited wf⇩t⇩r⇩m_def in blast)
lemma type_pgwt_inhabited: "wf⇩t⇩r⇩m t ⟹ ∃t'. Γ t = Γ t' ∧ public_ground_wf_term t'"
proof -
assume "wf⇩t⇩r⇩m t"
{ fix τ assume "Γ t = τ"
hence "∃t'. Γ t = Γ t' ∧ public_ground_wf_term t'" using ‹wf⇩t⇩r⇩m t›
proof (induction τ arbitrary: t)
case (Var a t)
then obtain c where "Γ t = Γ (Fun c [])" "arity c = 0" "public c"
using const_type_inv[of _ "[]" a] infinite_typed_consts(1)[of a] not_finite_existsD
by force
thus ?case using PGWT[OF ‹public c›, of "[]"] by auto
next
case (Fun f Y t)
have *: "arity f > 0" "public f" "arity f = length Y"
using fun_type_inv[OF ‹Γ t = TComp f Y›] fun_type_inv_wf[OF ‹Γ t = TComp f Y› ‹wf⇩t⇩r⇩m t›]
by auto
have "⋀y. y ∈ set Y ⟹ ∃t'. y = Γ t' ∧ public_ground_wf_term t'"
using Fun.prems(1) Fun.IH Γ_wf(1)[of _ _ t] Γ_wf'[OF ‹wf⇩t⇩r⇩m t›] type_wfttype_inhabited
by (metis Fun_param_is_subterm term.order_trans wf_trm_subtermeq)
hence "∃X. map Γ X = Y ∧ (∀x ∈ set X. public_ground_wf_term x)"
by (induct Y, simp_all, metis list.simps(9) set_ConsD)
then obtain X where X: "map Γ X = Y" "⋀x. x ∈ set X ⟹ public_ground_wf_term x" by moura
hence "arity f = length X" using *(3) by auto
have "Γ t = Γ (Fun f X)" "public_ground_wf_term (Fun f X)"
using fun_type[OF *(1), of X] Fun.prems(1) X(1) apply simp
using PGWT[OF *(2) ‹arity f = length X› X(2)] by metis
thus ?case by metis
qed
}
thus ?thesis using ‹wf⇩t⇩r⇩m t› by auto
qed
lemma pgwt_type_map:
assumes "public_ground_wf_term t"
shows "Γ t = TAtom a ⟹ ∃f. t = Fun f []" "Γ t = TComp g Y ⟹ ∃X. t = Fun g X ∧ map Γ X = Y"
proof -
let ?A = "Γ t = TAtom a ⟶ (∃f. t = Fun f [])"
let ?B = "Γ t = TComp g Y ⟶ (∃X. t = Fun g X ∧ map Γ X = Y)"
have "?A ∧ ?B"
proof (cases "Γ t")
case (Var a)
obtain f X where "t = Fun f X" "arity f = length X"
using pgwt_fun[OF assms(1)] pgwt_arity[OF assms(1)] by fastforce+
thus ?thesis using const_type_inv ‹Γ t = TAtom a› by auto
next
case (Fun g Y)
obtain f X where *: "t = Fun f X" using pgwt_fun[OF assms(1)] by force
hence "f = g" "map Γ X = Y"
using fun_type_id_eq ‹Γ t = TComp g Y› fun_type[OF fun_type_inv(1)[OF ‹Γ t = TComp g Y›]]
by fastforce+
thus ?thesis using *(1) ‹Γ t = TComp g Y› by auto
qed
thus "Γ t = TAtom a ⟹ ∃f. t = Fun f []" "Γ t = TComp g Y ⟹ ∃X. t = Fun g X ∧ map Γ X = Y"
by auto
qed
lemma wt_subst_Var[simp]: "wt⇩s⇩u⇩b⇩s⇩t Var" by (metis wt⇩s⇩u⇩b⇩s⇩t_def)
lemma wt_subst_trm: "(⋀v. v ∈ fv t ⟹ Γ (Var v) = Γ (θ v)) ⟹ Γ t = Γ (t ⋅ θ)"
proof (induction t)
case (Fun f X)
hence *: "⋀x. x ∈ set X ⟹ Γ x = Γ (x ⋅ θ)" by auto
show ?case
proof (cases "f ∈ Σ⇩f")
case True
hence "∀X. Γ (Fun f X) = TComp f (map Γ X)" using fun_type' by auto
thus ?thesis using * by auto
next
case False
hence "∃a ∈ 𝔗⇩a. ∀X. Γ (Fun f X) = TAtom a" using const_type' by auto
thus ?thesis by auto
qed
qed auto
lemma wt_subst_trm': "⟦wt⇩s⇩u⇩b⇩s⇩t σ; Γ s = Γ t⟧ ⟹ Γ (s ⋅ σ) = Γ (t ⋅ σ)"
by (metis wt_subst_trm wt⇩s⇩u⇩b⇩s⇩t_def)
lemma wt_subst_trm'': "wt⇩s⇩u⇩b⇩s⇩t σ ⟹ Γ t = Γ (t ⋅ σ)"
by (metis wt_subst_trm wt⇩s⇩u⇩b⇩s⇩t_def)
lemma wt_subst_compose:
assumes "wt⇩s⇩u⇩b⇩s⇩t θ" "wt⇩s⇩u⇩b⇩s⇩t δ" shows "wt⇩s⇩u⇩b⇩s⇩t (θ ∘⇩s δ)"
proof -
have "⋀v. Γ (θ v) = Γ (θ v ⋅ δ)" using wt_subst_trm ‹wt⇩s⇩u⇩b⇩s⇩t δ› unfolding wt⇩s⇩u⇩b⇩s⇩t_def by metis
moreover have "⋀v. Γ (Var v) = Γ (θ v)" using ‹wt⇩s⇩u⇩b⇩s⇩t θ› unfolding wt⇩s⇩u⇩b⇩s⇩t_def by metis
ultimately have "⋀v. Γ (Var v) = Γ (θ v ⋅ δ)" by metis
thus ?thesis unfolding wt⇩s⇩u⇩b⇩s⇩t_def subst_compose_def by metis
qed
lemma wt_subst_TAtom_Var_cases:
assumes θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and x: "Γ (Var x) = TAtom a"
shows "(∃y. θ x = Var y) ∨ (∃c. θ x = Fun c [])"
proof (cases "(∃y. θ x = Var y)")
case False
then obtain c T where c: "θ x = Fun c T"
by (cases "θ x") simp_all
hence "wf⇩t⇩r⇩m (Fun c T)"
using θ(2) by fastforce
hence "T = []"
using const_type_inv_wf[of c T a] x c wt_subst_trm''[OF θ(1), of "Var x"]
by fastforce
thus ?thesis
using c by blast
qed simp
lemma wt_subst_TAtom_fv:
assumes θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "∀x. wf⇩t⇩r⇩m (θ x)"
and "∀x ∈ fv t - X. ∃a. Γ (Var x) = TAtom a"
shows "∀x ∈ fv (t ⋅ θ) - fv⇩s⇩e⇩t (θ ` X). ∃a. Γ (Var x) = TAtom a"
using assms(3)
proof (induction t)
case (Var x) thus ?case
proof (cases "x ∈ X")
case False
with Var obtain a where "Γ (Var x) = TAtom a" by moura
hence *: "Γ (θ x) = TAtom a" "wf⇩t⇩r⇩m (θ x)" using θ unfolding wt⇩s⇩u⇩b⇩s⇩t_def by auto
show ?thesis
proof (cases "θ x")
case (Var y) thus ?thesis using * by auto
next
case (Fun f T)
hence "T = []" using * const_type_inv[of f T a] unfolding wf⇩t⇩r⇩m_def by auto
thus ?thesis using Fun by auto
qed
qed auto
qed fastforce
lemma wt_subst_TAtom_subterms_subst:
assumes "wt⇩s⇩u⇩b⇩s⇩t θ" "∀x ∈ fv t. ∃a. Γ (Var x) = TAtom a" "wf⇩t⇩r⇩m⇩s (θ ` fv t)"
shows "subterms (t ⋅ θ) = subterms t ⋅⇩s⇩e⇩t θ"
using assms(2,3)
proof (induction t)
case (Var x)
obtain a where a: "Γ (Var x) = TAtom a" using Var.prems(1) by moura
hence "Γ (θ x) = TAtom a" using wt_subst_trm''[OF assms(1), of "Var x"] by simp
hence "(∃y. θ x = Var y) ∨ (∃c. θ x = Fun c [])"
using const_type_inv_wf Var.prems(2) by (cases "θ x") auto
thus ?case by auto
next
case (Fun f T)
have "subterms (t ⋅ θ) = subterms t ⋅⇩s⇩e⇩t θ" when "t ∈ set T" for t
using that Fun.prems(1,2) Fun.IH[OF that]
by auto
thus ?case by auto
qed
lemma wt_subst_TAtom_subterms_set_subst:
assumes "wt⇩s⇩u⇩b⇩s⇩t θ" "∀x ∈ fv⇩s⇩e⇩t M. ∃a. Γ (Var x) = TAtom a" "wf⇩t⇩r⇩m⇩s (θ ` fv⇩s⇩e⇩t M)"
shows "subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ) = subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ"
proof
show "subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ) ⊆ subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ"
proof
fix t assume "t ∈ subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
then obtain s where s: "s ∈ M" "t ∈ subterms (s ⋅ θ)" by auto
thus "t ∈ subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ"
using assms(2,3) wt_subst_TAtom_subterms_subst[OF assms(1), of s]
by auto
qed
show "subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ ⊆ subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
proof
fix t assume "t ∈ subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ"
then obtain s where s: "s ∈ M" "t ∈ subterms s ⋅⇩s⇩e⇩t θ" by auto
thus "t ∈ subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
using assms(2,3) wt_subst_TAtom_subterms_subst[OF assms(1), of s]
by auto
qed
qed
lemma wt_subst_subst_upd:
assumes "wt⇩s⇩u⇩b⇩s⇩t θ"
and "Γ (Var x) = Γ t"
shows "wt⇩s⇩u⇩b⇩s⇩t (θ(x := t))"
using assms unfolding wt⇩s⇩u⇩b⇩s⇩t_def
by (metis fun_upd_other fun_upd_same)
lemma wt_subst_const_fv_type_eq:
assumes "∀x ∈ fv t. ∃a. Γ (Var x) = TAtom a"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "∀x ∈ fv (t ⋅ δ). ∃y ∈ fv t. Γ (Var x) = Γ (Var y)"
using assms(1)
proof (induction t)
case (Var x)
then obtain a where a: "Γ (Var x) = TAtom a" by moura
show ?case
proof (cases "δ x")
case (Fun f T)
hence "wf⇩t⇩r⇩m (Fun f T)" "Γ (Fun f T) = TAtom a"
using a wt_subst_trm''[OF δ(1), of "Var x"] δ(2) by fastforce+
thus ?thesis using const_type_inv_wf Fun by fastforce
qed (use a wt_subst_trm''[OF δ(1), of "Var x"] in simp)
qed fastforce
lemma TComp_term_cases:
assumes "wf⇩t⇩r⇩m t" "Γ t = TComp f T"
shows "(∃v. t = Var v) ∨ (∃T'. t = Fun f T' ∧ T = map Γ T' ∧ T' ≠ [])"
proof (cases "∃v. t = Var v")
case False
then obtain T' where T': "t = Fun f T'" "T = map Γ T'"
using assms fun_type[OF fun_type_inv(1)[OF assms(2)]] fun_type_id_eq
by (cases t) force+
thus ?thesis using assms fun_type_inv(1) fun_type_inv_wf by fastforce
qed metis
lemma TAtom_term_cases:
assumes "wf⇩t⇩r⇩m t" "Γ t = TAtom τ"
shows "(∃v. t = Var v) ∨ (∃f. t = Fun f [])"
using assms const_type_inv unfolding wf⇩t⇩r⇩m_def by (cases t) auto
lemma subtermeq_imp_subtermtypeeq:
assumes "wf⇩t⇩r⇩m t" "s ⊑ t"
shows "Γ s ⊑ Γ t"
using assms(2,1)
proof (induction t)
case (Fun f T) thus ?case
proof (cases "s = Fun f T")
case False
then obtain x where x: "x ∈ set T" "s ⊑ x" using Fun.prems(1) by auto
hence "wf⇩t⇩r⇩m x" using wf_trm_subtermeq[OF Fun.prems(2)] Fun_param_is_subterm[of _ T f] by auto
hence "Γ s ⊑ Γ x" using Fun.IH[OF x] by simp
moreover have "arity f > 0" using x fun_type_inv_wf Fun.prems
by (metis length_pos_if_in_set term.order_refl wf⇩t⇩r⇩m_def)
ultimately show ?thesis using x Fun.prems fun_type[of f T] by auto
qed simp
qed simp
lemma subterm_funs_term_in_type:
assumes "wf⇩t⇩r⇩m t" "Fun f T ⊑ t" "Γ (Fun f T) = TComp f (map Γ T)"
shows "f ∈ funs_term (Γ t)"
using assms(2,1,3)
proof (induction t)
case (Fun f' T')
hence [simp]: "wf⇩t⇩r⇩m (Fun f T)" by (metis wf_trm_subtermeq)
{ fix a assume τ: "Γ (Fun f' T') = TAtom a"
hence "Fun f T = Fun f' T'" using Fun TAtom_term_cases subtermeq_Var_const by metis
hence False using Fun.prems(3) τ by simp
}
moreover
{ fix g S assume τ: "Γ (Fun f' T') = TComp g S"
hence "g = f'" "S = map Γ T'"
using Fun.prems(2) fun_type_id_eq[OF τ] fun_type[OF fun_type_inv(1)[OF τ]]
by auto
hence τ': "Γ (Fun f' T') = TComp f' (map Γ T')" using τ by auto
hence "g ∈ funs_term (Γ (Fun f' T'))" using τ by auto
moreover {
assume "Fun f T ≠ Fun f' T'"
then obtain x where "x ∈ set T'" "Fun f T ⊑ x" using Fun.prems(1) by auto
hence "f ∈ funs_term (Γ x)"
using Fun.IH[OF _ _ _ Fun.prems(3), of x] wf_trm_subtermeq[OF ‹wf⇩t⇩r⇩m (Fun f' T')›, of x]
by force
moreover have "Γ x ∈ set (map Γ T')" using τ' ‹x ∈ set T'› by auto
ultimately have "f ∈ funs_term (Γ (Fun f' T'))" using τ' by auto
}
ultimately have ?case by (cases "Fun f T = Fun f' T'") (auto simp add: ‹g = f'›)
}
ultimately show ?case by (cases "Γ (Fun f' T')") auto
qed simp
lemma wt_subst_fv_termtype_subterm:
assumes "x ∈ fv (θ y)"
and "wt⇩s⇩u⇩b⇩s⇩t θ"
and "wf⇩t⇩r⇩m (θ y)"
shows "Γ (Var x) ⊑ Γ (Var y)"
using subtermeq_imp_subtermtypeeq[OF assms(3) var_is_subterm[OF assms(1)]]
wt_subst_trm''[OF assms(2), of "Var y"]
by auto
lemma wt_subst_fv⇩s⇩e⇩t_termtype_subterm:
assumes "x ∈ fv⇩s⇩e⇩t (θ ` Y)"
and "wt⇩s⇩u⇩b⇩s⇩t θ"
and "wf⇩t⇩r⇩m⇩s (subst_range θ)"
shows "∃y ∈ Y. Γ (Var x) ⊑ Γ (Var y)"
using wt_subst_fv_termtype_subterm[OF _ assms(2), of x] assms(1,3)
by fastforce
lemma funs_term_type_iff:
assumes t: "wf⇩t⇩r⇩m t"
and f: "arity f > 0"
shows "f ∈ funs_term (Γ t) ⟷ (f ∈ funs_term t ∨ (∃x ∈ fv t. f ∈ funs_term (Γ (Var x))))"
(is "?P t ⟷ ?Q t")
using t
proof (induction t)
case (Fun g T)
hence IH: "?P s ⟷ ?Q s" when "s ∈ set T" for s
using that wf_trm_subterm[OF _ Fun_param_is_subterm]
by blast
have 0: "arity g = length T" using Fun.prems unfolding wf⇩t⇩r⇩m_def by auto
show ?case
proof (cases "f = g")
case True thus ?thesis using fun_type[OF f] by simp
next
case False
have "?P (Fun g T) ⟷ (∃s ∈ set T. ?P s)"
proof
assume *: "?P (Fun g T)"
hence "Γ (Fun g T) = TComp g (map Γ T)"
using const_type[of g] fun_type[of g] by force
thus "∃s ∈ set T. ?P s" using False * by force
next
assume *: "∃s ∈ set T. ?P s"
hence "Γ (Fun g T) = TComp g (map Γ T)"
using 0 const_type[of g] fun_type[of g] by force
thus "?P (Fun g T)" using False * by force
qed
thus ?thesis using False f IH by auto
qed
qed simp
lemma funs_term_type_iff':
assumes M: "wf⇩t⇩r⇩m⇩s M"
and f: "arity f > 0"
shows "f ∈ ⋃(funs_term ` Γ ` M) ⟷
(f ∈ ⋃(funs_term ` M) ∨ (∃x ∈ fv⇩s⇩e⇩t M. f ∈ funs_term (Γ (Var x))))" (is "?A ⟷ ?B")
proof
assume ?A
then obtain t where "t ∈ M" "wf⇩t⇩r⇩m t" "f ∈ funs_term (Γ t)" using M by moura
thus ?B using funs_term_type_iff[OF _ f, of t] by auto
next
assume ?B
then obtain t where "t ∈ M" "wf⇩t⇩r⇩m t" "f ∈ funs_term t ∨ (∃x ∈ fv t. f ∈ funs_term (Γ (Var x)))"
using M by auto
thus ?A using funs_term_type_iff[OF _ f, of t] by blast
qed
lemma Ana_subterm_type:
assumes "Ana t = (K,M)"
and "wf⇩t⇩r⇩m t"
and "m ∈ set M"
shows "Γ m ⊑ Γ t"
proof -
have "m ⊑ t" using Ana_subterm[OF assms(1)] assms(3) by auto
thus ?thesis using subtermeq_imp_subtermtypeeq[OF assms(2)] by simp
qed
lemma wf_trm_TAtom_subterms:
assumes "wf⇩t⇩r⇩m t" "Γ t = TAtom τ"
shows "subterms t = {t}"
using assms const_type_inv unfolding wf⇩t⇩r⇩m_def by (cases t) force+
lemma wf_trm_TComp_subterm:
assumes "wf⇩t⇩r⇩m s" "t ⊏ s"
obtains f T where "Γ s = TComp f T"
proof (cases s)
case (Var x) thus ?thesis using ‹t ⊏ s› by simp
next
case (Fun g S)
hence "length S > 0" using assms Fun_subterm_inside_params[of t g S] by auto
hence "arity g > 0" by (metis ‹wf⇩t⇩r⇩m s› ‹s = Fun g S› term.order_refl wf⇩t⇩r⇩m_def)
thus ?thesis using fun_type ‹s = Fun g S› that by auto
qed
lemma SMP_empty[simp]: "SMP {} = {}"
proof (rule ccontr)
assume "SMP {} ≠ {}"
then obtain t where "t ∈ SMP {}" by auto
thus False by (induct t rule: SMP.induct) auto
qed
lemma SMP_I:
assumes "s ∈ M" "wt⇩s⇩u⇩b⇩s⇩t δ" "t ⊑ s ⋅ δ" "⋀v. wf⇩t⇩r⇩m (δ v)"
shows "t ∈ SMP M"
using SMP.Substitution[OF SMP.MP[OF assms(1)] assms(2)] SMP.Subterm[of "s ⋅ δ" M t] assms(3,4)
by (cases "t = s ⋅ δ") simp_all
lemma SMP_wf_trm:
assumes "t ∈ SMP M" "wf⇩t⇩r⇩m⇩s M"
shows "wf⇩t⇩r⇩m t"
using assms(1)
by (induct t rule: SMP.induct)
(use assms(2) in blast,
use wf_trm_subtermeq in blast,
use wf_trm_subst in blast,
use Ana_keys_wf' in blast)
lemma SMP_ikI[intro]: "t ∈ ik⇩s⇩t S ⟹ t ∈ SMP (trms⇩s⇩t S)" by force
lemma MP_setI[intro]: "x ∈ set S ⟹ trms⇩s⇩t⇩p x ⊆ trms⇩s⇩t S" by force
lemma SMP_setI[intro]: "x ∈ set S ⟹ trms⇩s⇩t⇩p x ⊆ SMP (trms⇩s⇩t S)" by force
lemma SMP_subset_I:
assumes M: "∀t ∈ M. ∃s δ. s ∈ N ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = s ⋅ δ"
shows "SMP M ⊆ SMP N"
proof
fix t show "t ∈ SMP M ⟹ t ∈ SMP N"
proof (induction t rule: SMP.induct)
case (MP t)
then obtain s δ where s: "s ∈ N" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" "t = s ⋅ δ"
using M by moura
show ?case using SMP_I[OF s(1,2), of "s ⋅ δ"] s(3,4) wf_trm_subst_range_iff by fast
qed (auto intro!: SMP.Substitution[of _ N])
qed
lemma SMP_union: "SMP (A ∪ B) = SMP A ∪ SMP B"
proof
show "SMP (A ∪ B) ⊆ SMP A ∪ SMP B"
proof
fix t assume "t ∈ SMP (A ∪ B)"
thus "t ∈ SMP A ∪ SMP B" by (induct rule: SMP.induct) blast+
qed
{ fix t assume "t ∈ SMP A" hence "t ∈ SMP (A ∪ B)" by (induct rule: SMP.induct) blast+ }
moreover { fix t assume "t ∈ SMP B" hence "t ∈ SMP (A ∪ B)" by (induct rule: SMP.induct) blast+ }
ultimately show "SMP A ∪ SMP B ⊆ SMP (A ∪ B)" by blast
qed
lemma SMP_append[simp]: "SMP (trms⇩s⇩t (S@S')) = SMP (trms⇩s⇩t S) ∪ SMP (trms⇩s⇩t S')" (is "?A = ?B")
using SMP_union by simp
lemma SMP_mono: "A ⊆ B ⟹ SMP A ⊆ SMP B"
proof -
assume "A ⊆ B"
then obtain C where "B = A ∪ C" by moura
thus "SMP A ⊆ SMP B" by (simp add: SMP_union)
qed
lemma SMP_Union: "SMP (⋃m ∈ M. f m) = (⋃m ∈ M. SMP (f m))"
proof
show "SMP (⋃m∈M. f m) ⊆ (⋃m∈M. SMP (f m))"
proof
fix t assume "t ∈ SMP (⋃m∈M. f m)"
thus "t ∈ (⋃m∈M. SMP (f m))" by (induct t rule: SMP.induct) force+
qed
show "(⋃m∈M. SMP (f m)) ⊆ SMP (⋃m∈M. f m)"
proof
fix t assume "t ∈ (⋃m∈M. SMP (f m))"
then obtain m where "m ∈ M" "t ∈ SMP (f m)" by moura
thus "t ∈ SMP (⋃m∈M. f m)" using SMP_mono[of "f m" "⋃m∈M. f m"] by auto
qed
qed
lemma SMP_singleton_ex:
"t ∈ SMP M ⟹ (∃m ∈ M. t ∈ SMP {m})"
"m ∈ M ⟹ t ∈ SMP {m} ⟹ t ∈ SMP M"
using SMP_Union[of "λt. {t}" M] by auto
lemma SMP_Cons: "SMP (trms⇩s⇩t (x#S)) = SMP (trms⇩s⇩t [x]) ∪ SMP (trms⇩s⇩t S)"
using SMP_append[of "[x]" S] by auto
lemma SMP_Nil[simp]: "SMP (trms⇩s⇩t []) = {}"
proof -
{ fix t assume "t ∈ SMP (trms⇩s⇩t [])" hence False by induct auto }
thus ?thesis by blast
qed
lemma SMP_subset_union_eq: assumes "M ⊆ SMP N" shows "SMP N = SMP (M ∪ N)"
proof -
{ fix t assume "t ∈ SMP (M ∪ N)" hence "t ∈ SMP N"
using assms by (induction rule: SMP.induct) blast+
}
thus ?thesis using SMP_union by auto
qed
lemma SMP_subterms_subset: "subterms⇩s⇩e⇩t M ⊆ SMP M"
proof
fix t assume "t ∈ subterms⇩s⇩e⇩t M"
then obtain m where "m ∈ M" "t ⊑ m" by auto
thus "t ∈ SMP M" using SMP_I[of _ _ Var] by auto
qed
lemma SMP_SMP_subset: "N ⊆ SMP M ⟹ SMP N ⊆ SMP M"
by (metis SMP_mono SMP_subset_union_eq Un_commute Un_upper2)
lemma wt_subst_rm_vars: "wt⇩s⇩u⇩b⇩s⇩t δ ⟹ wt⇩s⇩u⇩b⇩s⇩t (rm_vars X δ)"
using rm_vars_dom unfolding wt⇩s⇩u⇩b⇩s⇩t_def by auto
lemma wt_subst_SMP_subset:
assumes "trms⇩s⇩t S ⊆ SMP S'" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "trms⇩s⇩t (S ⋅⇩s⇩t δ) ⊆ SMP S'"
proof
fix t assume *: "t ∈ trms⇩s⇩t (S ⋅⇩s⇩t δ)"
show "t ∈ SMP S'" using trm_strand_subst_cong(2)[OF *]
proof
assume "∃t'. t = t' ⋅ δ ∧ t' ∈ trms⇩s⇩t S"
thus "t ∈ SMP S'" using assms SMP.Substitution by auto
next
assume "∃X F. Inequality X F ∈ set S ∧ (∃t'∈trms⇩p⇩a⇩i⇩r⇩s F. t = t' ⋅ rm_vars (set X) δ)"
then obtain X F t' where **:
"Inequality X F ∈ set S" "t'∈trms⇩p⇩a⇩i⇩r⇩s F" "t = t' ⋅ rm_vars (set X) δ"
by force
then obtain s where s: "s ∈ trms⇩s⇩t⇩p (Inequality X F)" "t = s ⋅ rm_vars (set X) δ" by moura
hence "s ∈ SMP (trms⇩s⇩t S)" using **(1) by force
hence "t ∈ SMP (trms⇩s⇩t S)"
using SMP.Substitution[OF _ wt_subst_rm_vars[OF assms(2)] wf_trms_subst_rm_vars'[OF assms(3)]]
unfolding s(2) by blast
thus "t ∈ SMP S'" by (metis SMP_union SMP_subset_union_eq UnCI assms(1))
qed
qed
lemma MP_subset_SMP: "⋃(trms⇩s⇩t⇩p ` set S) ⊆ SMP (trms⇩s⇩t S)" "trms⇩s⇩t S ⊆ SMP (trms⇩s⇩t S)" "M ⊆ SMP M"
by auto
lemma SMP_fun_map_snd_subset: "SMP (trms⇩s⇩t (map Send X)) ⊆ SMP (trms⇩s⇩t [Send (Fun f X)])"
proof
fix t assume "t ∈ SMP (trms⇩s⇩t (map Send X))" thus "t ∈ SMP (trms⇩s⇩t [Send (Fun f X)])"
proof (induction t rule: SMP.induct)
case (MP t)
hence "t ∈ set X" by auto
hence "t ⊏ Fun f X" by (metis subtermI')
thus ?case using SMP.Subterm[of "Fun f X" "trms⇩s⇩t [Send (Fun f X)]" t] using SMP.MP by auto
qed blast+
qed
lemma SMP_wt_subst_subset:
assumes "t ∈ SMP (M ⋅⇩s⇩e⇩t ℐ)" "wt⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
shows "t ∈ SMP M"
using assms wf_trm_subst_range_iff[of ℐ] by (induct t rule: SMP.induct) blast+
lemma SMP_wt_instances_subset:
assumes "∀t ∈ M. ∃s ∈ N. ∃δ. t = s ⋅ δ ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
and "t ∈ SMP M"
shows "t ∈ SMP N"
proof -
obtain m where m: "m ∈ M" "t ∈ SMP {m}" using SMP_singleton_ex(1)[OF assms(2)] by blast
then obtain n δ where n: "n ∈ N" "m = n ⋅ δ" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using assms(1) by fast
have "t ∈ SMP (N ⋅⇩s⇩e⇩t δ)" using n(1,2) SMP_singleton_ex(2)[of m "N ⋅⇩s⇩e⇩t δ", OF _ m(2)] by fast
thus ?thesis using SMP_wt_subst_subset[OF _ n(3,4)] by blast
qed
lemma SMP_consts:
assumes "∀t ∈ M. ∃c. t = Fun c []"
and "∀t ∈ M. Ana t = ([], [])"
shows "SMP M = M"
proof
show "SMP M ⊆ M"
proof
fix t show "t ∈ SMP M ⟹ t ∈ M"
apply (induction t rule: SMP.induct)
by (use assms in auto)
qed
qed auto
lemma SMP_subterms_eq:
"SMP (subterms⇩s⇩e⇩t M) = SMP M"
proof
show "SMP M ⊆ SMP (subterms⇩s⇩e⇩t M)" using SMP_mono[of M "subterms⇩s⇩e⇩t M"] by blast
show "SMP (subterms⇩s⇩e⇩t M) ⊆ SMP M"
proof
fix t show "t ∈ SMP (subterms⇩s⇩e⇩t M) ⟹ t ∈ SMP M" by (induction t rule: SMP.induct) blast+
qed
qed
lemma SMP_funs_term:
assumes t: "t ∈ SMP M" "f ∈ funs_term t ∨ (∃x ∈ fv t. f ∈ funs_term (Γ (Var x)))"
and f: "arity f > 0"
and M: "wf⇩t⇩r⇩m⇩s M"
and Ana_f: "⋀s K T. Ana s = (K,T) ⟹ f ∈ ⋃(funs_term ` set K) ⟹ f ∈ funs_term s"
shows "f ∈ ⋃(funs_term ` M) ∨ (∃x ∈ fv⇩s⇩e⇩t M. f ∈ funs_term (Γ (Var x)))"
using t
proof (induction t rule: SMP.induct)
case (Subterm t t')
thus ?case by (metis UN_I vars_iff_subtermeq funs_term_subterms_eq(1) term.order_trans)
next
case (Substitution t δ)
show ?case
using M SMP_wf_trm[OF Substitution.hyps(1)] wf_trm_subst[of δ t, OF Substitution.hyps(3)]
funs_term_type_iff[OF _ f] wt_subst_trm''[OF Substitution.hyps(2), of t]
Substitution.prems Substitution.IH
by metis
next
case (Ana t K T t')
thus ?case
using Ana_f[OF Ana.hyps(2)] Ana_keys_fv[OF Ana.hyps(2)]
by fastforce
qed auto
lemma id_type_eq:
assumes "Γ (Fun f X) = Γ (Fun g Y)"
shows "f ∈ 𝒞 ⟹ g ∈ 𝒞" "f ∈ Σ⇩f ⟹ g ∈ Σ⇩f"
using assms const_type' fun_type' id_union_univ(1)
by (metis UNIV_I UnE "term.distinct"(1))+
lemma fun_type_arg_cong:
assumes "f ∈ Σ⇩f" "g ∈ Σ⇩f" "Γ (Fun f (x#X)) = Γ (Fun g (y#Y))"
shows "Γ x = Γ y" "Γ (Fun f X) = Γ (Fun g Y)"
using assms fun_type' by auto
lemma fun_type_arg_cong':
assumes "f ∈ Σ⇩f" "g ∈ Σ⇩f" "Γ (Fun f (X@x#X')) = Γ (Fun g (Y@y#Y'))" "length X = length Y"
shows "Γ x = Γ y"
using assms
proof (induction X arbitrary: Y)
case Nil thus ?case using fun_type_arg_cong(1)[of f g x X' y Y'] by auto
next
case (Cons x' X Y'')
then obtain y' Y where "Y'' = y'#Y" by (metis length_Suc_conv)
hence "Γ (Fun f (X@x#X')) = Γ (Fun g (Y@y#Y'))" "length X = length Y"
using Cons.prems(3,4) fun_type_arg_cong(2)[OF Cons.prems(1,2), of x' "X@x#X'"] by auto
thus ?thesis using Cons.IH[OF Cons.prems(1,2)] by auto
qed
lemma fun_type_param_idx: "Γ (Fun f T) = Fun g S ⟹ i < length T ⟹ Γ (T ! i) = S ! i"
by (metis fun_type fun_type_id_eq fun_type_inv(1) nth_map term.inject(2))
lemma fun_type_param_ex:
assumes "Γ (Fun f T) = Fun g (map Γ S)" "t ∈ set S"
shows "∃s ∈ set T. Γ s = Γ t"
using fun_type_length_eq[OF assms(1)] length_map[of Γ S] assms(2)
fun_type_param_idx[OF assms(1)] nth_map in_set_conv_nth
by metis
lemma tfr_stp_all_split:
"list_all tfr⇩s⇩t⇩p (x#S) ⟹ list_all tfr⇩s⇩t⇩p [x]"
"list_all tfr⇩s⇩t⇩p (x#S) ⟹ list_all tfr⇩s⇩t⇩p S"
"list_all tfr⇩s⇩t⇩p (S@S') ⟹ list_all tfr⇩s⇩t⇩p S"
"list_all tfr⇩s⇩t⇩p (S@S') ⟹ list_all tfr⇩s⇩t⇩p S'"
"list_all tfr⇩s⇩t⇩p (S@x#S') ⟹ list_all tfr⇩s⇩t⇩p (S@S')"
by fastforce+
lemma tfr_stp_all_append:
assumes "list_all tfr⇩s⇩t⇩p S" "list_all tfr⇩s⇩t⇩p S'"
shows "list_all tfr⇩s⇩t⇩p (S@S')"
using assms by fastforce
lemma tfr_stp_all_wt_subst_apply:
assumes "list_all tfr⇩s⇩t⇩p S"
and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
"bvars⇩s⇩t S ∩ range_vars θ = {}"
shows "list_all tfr⇩s⇩t⇩p (S ⋅⇩s⇩t θ)"
using assms(1,4)
proof (induction S)
case (Cons x S)
hence IH: "list_all tfr⇩s⇩t⇩p (S ⋅⇩s⇩t θ)"
using tfr_stp_all_split(2)[of x S]
unfolding range_vars_alt_def by fastforce
thus ?case
proof (cases x)
case (Equality a t t')
hence "(∃δ. Unifier δ t t') ⟶ Γ t = Γ t'" using Cons.prems by auto
hence "(∃δ. Unifier δ (t ⋅ θ) (t' ⋅ θ)) ⟶ Γ (t ⋅ θ) = Γ (t' ⋅ θ)"
by (metis Unifier_comp' wt_subst_trm'[OF assms(2)])
moreover have "(x#S) ⋅⇩s⇩t θ = Equality a (t ⋅ θ) (t' ⋅ θ)#(S ⋅⇩s⇩t θ)"
using ‹x = Equality a t t'› by auto
ultimately show ?thesis using IH by auto
next
case (Inequality X F)
let ?σ = "rm_vars (set X) θ"
let ?G = "F ⋅⇩p⇩a⇩i⇩r⇩s ?σ"
let ?P = "λF X. ∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. ∃a. Γ (Var x) = TAtom a"
let ?Q = "λF X.
∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X)"
have 0: "set X ∩ range_vars ?σ = {}"
using Cons.prems(2) Inequality rm_vars_img_subset[of "set X"]
by (auto simp add: subst_domain_def range_vars_alt_def)
have 1: "?P F X ∨ ?Q F X" using Inequality Cons.prems by simp
have 2: "fv⇩s⇩e⇩t (?σ ` set X) = set X" by auto
have "?P ?G X" when "?P F X" using that
proof (induction F)
case (Cons g G)
obtain t t' where g: "g = (t,t')" by (metis surj_pair)
have "∀x ∈ (fv (t ⋅ ?σ) ∪ fv (t' ⋅ ?σ)) - set X. ∃a. Γ (Var x) = Var a"
proof -
have *: "∀x ∈ fv t - set X. ∃a. Γ (Var x) = Var a"
"∀x ∈ fv t' - set X. ∃a. Γ (Var x) = Var a"
using g Cons.prems by simp_all
have **: "∀x. wf⇩t⇩r⇩m (?σ x)"
using θ(2) wf_trm_subst_range_iff[of θ] wf_trm_subst_rm_vars'[of θ _ "set X"] by simp
show ?thesis
using wt_subst_TAtom_fv[OF wt_subst_rm_vars[OF θ(1)] ** *(1)]
wt_subst_TAtom_fv[OF wt_subst_rm_vars[OF θ(1)] ** *(2)]
wt_subst_trm'[OF wt_subst_rm_vars[OF θ(1), of "set X"]] 2
by blast
qed
moreover have "∀x∈fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s ?σ) - set X. ∃a. Γ (Var x) = Var a"
using Cons by auto
ultimately show ?case using g by (auto simp add: subst_apply_pairs_def)
qed (simp add: subst_apply_pairs_def)
hence "?P ?G X ∨ ?Q ?G X"
using 1 ineq_subterm_inj_cond_subst[OF 0, of "trms⇩p⇩a⇩i⇩r⇩s F"] trms⇩p⇩a⇩i⇩r⇩s_subst[of F ?σ]
by presburger
moreover have "(x#S) ⋅⇩s⇩t θ = Inequality X (F ⋅⇩p⇩a⇩i⇩r⇩s ?σ)#(S ⋅⇩s⇩t θ)"
using ‹x = Inequality X F› by auto
ultimately show ?thesis using IH by simp
qed auto
qed simp
lemma tfr_stp_all_same_type:
"list_all tfr⇩s⇩t⇩p (S@Equality a t t'#S') ⟹ Unifier δ t t' ⟹ Γ t = Γ t'"
by force+
lemma tfr_subset:
"⋀A B. tfr⇩s⇩e⇩t (A ∪ B) ⟹ tfr⇩s⇩e⇩t A"
"⋀A B. tfr⇩s⇩e⇩t B ⟹ A ⊆ B ⟹ tfr⇩s⇩e⇩t A"
"⋀A B. tfr⇩s⇩e⇩t B ⟹ SMP A ⊆ SMP B ⟹ tfr⇩s⇩e⇩t A"
proof -
show 1: "tfr⇩s⇩e⇩t (A ∪ B) ⟹ tfr⇩s⇩e⇩t A" for A B
using SMP_union[of A B] unfolding tfr⇩s⇩e⇩t_def by simp
fix A B assume B: "tfr⇩s⇩e⇩t B"
show "A ⊆ B ⟹ tfr⇩s⇩e⇩t A"
proof -
assume "A ⊆ B"
then obtain C where "B = A ∪ C" by moura
thus ?thesis using B 1 by blast
qed
show "SMP A ⊆ SMP B ⟹ tfr⇩s⇩e⇩t A"
proof -
assume "SMP A ⊆ SMP B"
then obtain C where "SMP B = SMP A ∪ C" by moura
thus ?thesis using B unfolding tfr⇩s⇩e⇩t_def by blast
qed
qed
lemma tfr_empty[simp]: "tfr⇩s⇩e⇩t {}"
unfolding tfr⇩s⇩e⇩t_def by simp
lemma tfr_consts_mono:
assumes "∀t ∈ M. ∃c. t = Fun c []"
and "∀t ∈ M. Ana t = ([], [])"
and "tfr⇩s⇩e⇩t N"
shows "tfr⇩s⇩e⇩t (N ∪ M)"
proof -
{ fix s t
assume *: "s ∈ SMP (N ∪ M) - range Var" "t ∈ SMP (N ∪ M) - range Var" "∃δ. Unifier δ s t"
hence **: "is_Fun s" "is_Fun t" "s ∈ SMP N ∨ s ∈ M" "t ∈ SMP N ∨ t ∈ M"
using assms(3) SMP_consts[OF assms(1,2)] SMP_union[of N M] by auto
moreover have "Γ s = Γ t" when "s ∈ SMP N" "t ∈ SMP N"
using that assms(3) *(3) **(1,2) unfolding tfr⇩s⇩e⇩t_def by blast
moreover have "Γ s = Γ t" when st: "s ∈ M" "t ∈ M"
proof -
obtain c d where "s = Fun c []" "t = Fun d []" using st assms(1) by moura
hence "s = t" using *(3) by fast
thus ?thesis by metis
qed
moreover have "Γ s = Γ t" when st: "s ∈ SMP N" "t ∈ M"
proof -
obtain c where "t = Fun c []" using st assms(1) by moura
hence "s = t" using *(3) **(1,2) by auto
thus ?thesis by metis
qed
moreover have "Γ s = Γ t" when st: "s ∈ M" "t ∈ SMP N"
proof -
obtain c where "s = Fun c []" using st assms(1) by moura
hence "s = t" using *(3) **(1,2) by auto
thus ?thesis by metis
qed
ultimately have "Γ s = Γ t" by metis
} thus ?thesis by (metis tfr⇩s⇩e⇩t_def)
qed
lemma dual⇩s⇩t_tfr⇩s⇩t⇩p: "list_all tfr⇩s⇩t⇩p S ⟹ list_all tfr⇩s⇩t⇩p (dual⇩s⇩t S)"
proof (induction S)
case (Cons x S)
have "list_all tfr⇩s⇩t⇩p S" using Cons.prems by simp
hence IH: "list_all tfr⇩s⇩t⇩p (dual⇩s⇩t S)" using Cons.IH by metis
from Cons show ?case
proof (cases x)
case (Equality a t t')
hence "(∃δ. Unifier δ t t') ⟹ Γ t = Γ t'" using Cons by auto
thus ?thesis using Equality IH by fastforce
next
case (Inequality X F)
have "set (dual⇩s⇩t (x#S)) = insert x (set (dual⇩s⇩t S))" using Inequality by auto
moreover have "(∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. ∃a. Γ (Var x) = Var a) ∨
(∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))"
using Cons.prems Inequality by auto
ultimately show ?thesis using Inequality IH by auto
qed auto
qed simp
lemma subst_var_inv_wt:
assumes "wt⇩s⇩u⇩b⇩s⇩t δ"
shows "wt⇩s⇩u⇩b⇩s⇩t (subst_var_inv δ X)"
using assms f_inv_into_f[of _ δ X]
unfolding wt⇩s⇩u⇩b⇩s⇩t_def subst_var_inv_def
by presburger
lemma subst_var_inv_wf_trms:
"wf⇩t⇩r⇩m⇩s (subst_range (subst_var_inv δ X))"
using f_inv_into_f[of _ δ X]
unfolding wt⇩s⇩u⇩b⇩s⇩t_def subst_var_inv_def
by auto
lemma unify_list_wt_if_same_type:
assumes "Unification.unify E B = Some U" "∀(s,t) ∈ set E. wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t ∧ Γ s = Γ t"
and "∀(v,t) ∈ set B. Γ (Var v) = Γ t"
shows "∀(v,t) ∈ set U. Γ (Var v) = Γ t"
using assms
proof (induction E B arbitrary: U rule: Unification.unify.induct)
case (2 f X g Y E B U)
hence "wf⇩t⇩r⇩m (Fun f X)" "wf⇩t⇩r⇩m (Fun g Y)" "Γ (Fun f X) = Γ (Fun g Y)" by auto
from "2.prems"(1) obtain E' where *: "decompose (Fun f X) (Fun g Y) = Some E'"
and [simp]: "f = g" "length X = length Y" "E' = zip X Y"
and **: "Unification.unify (E'@E) B = Some U"
by (auto split: option.splits)
have "∀(s,t) ∈ set E'. wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t ∧ Γ s = Γ t"
proof -
{ fix s t assume "(s,t) ∈ set E'"
then obtain X' X'' Y' Y'' where "X = X'@s#X''" "Y = Y'@t#Y''" "length X' = length Y'"
using zip_arg_subterm_split[of s t X Y] ‹E' = zip X Y› by metis
hence "Γ (Fun f (X'@s#X'')) = Γ (Fun g (Y'@t#Y''))" by (metis ‹Γ (Fun f X) = Γ (Fun g Y)›)
from ‹E' = zip X Y› have "∀(s,t) ∈ set E'. s ⊏ Fun f X ∧ t ⊏ Fun g Y"
using zip_arg_subterm[of _ _ X Y] by blast
with ‹(s,t) ∈ set E'› have "wf⇩t⇩r⇩m s" "wf⇩t⇩r⇩m t"
using wf_trm_subterm ‹wf⇩t⇩r⇩m (Fun f X)› ‹wf⇩t⇩r⇩m (Fun g Y)› by (blast,blast)
moreover have "f ∈ Σ⇩f"
proof (rule ccontr)
assume "f ∉ Σ⇩f"
hence "f ∈ 𝒞" "arity f = 0" using const_arity_eq_zero[of f] by simp_all
thus False using ‹wf⇩t⇩r⇩m (Fun f X)› * ‹(s,t) ∈ set E'› unfolding wf⇩t⇩r⇩m_def by auto
qed
hence "Γ s = Γ t"
using fun_type_arg_cong' ‹f ∈ Σ⇩f› ‹Γ (Fun f (X'@s#X'')) = Γ (Fun g (Y'@t#Y''))›
‹length X' = length Y'› ‹f = g›
by metis
ultimately have "wf⇩t⇩r⇩m s" "wf⇩t⇩r⇩m t" "Γ s = Γ t" by metis+
}
thus ?thesis by blast
qed
moreover have "∀(s,t) ∈ set E. wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t ∧ Γ s = Γ t" using "2.prems"(2) by auto
ultimately show ?case using "2.IH"[OF * ** _ "2.prems"(3)] by fastforce
next
case (3 v t E B U)
hence "Γ (Var v) = Γ t" "wf⇩t⇩r⇩m t" by auto
hence "wt⇩s⇩u⇩b⇩s⇩t (subst v t)"
and *: "∀(v, t) ∈ set ((v,t)#B). Γ (Var v) = Γ t"
"⋀t t'. (t,t') ∈ set E ⟹ Γ t = Γ t'"
using "3.prems"(2,3) unfolding wt⇩s⇩u⇩b⇩s⇩t_def subst_def by auto
show ?case
proof (cases "t = Var v")
assume "t = Var v" thus ?case using 3 by auto
next
assume "t ≠ Var v"
hence "v ∉ fv t" using "3.prems"(1) by auto
hence **: "Unification.unify (subst_list (subst v t) E) ((v, t)#B) = Some U"
using Unification.unify.simps(3)[of v t E B] "3.prems"(1) ‹t ≠ Var v› by auto
have "∀(s, t) ∈ set (subst_list (subst v t) E). wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t"
using wf_trm_subst_singleton[OF _ ‹wf⇩t⇩r⇩m t›] "3.prems"(2)
unfolding subst_list_def subst_def by auto
moreover have "∀(s, t) ∈ set (subst_list (subst v t) E). Γ s = Γ t"
using *(2)[THEN wt_subst_trm'[OF ‹wt⇩s⇩u⇩b⇩s⇩t (subst v t)›]] by (simp add: subst_list_def)
ultimately show ?thesis using "3.IH"(2)[OF ‹t ≠ Var v› ‹v ∉ fv t› ** _ *(1)] by auto
qed
next
case (4 f X v E B U)
hence "Γ (Var v) = Γ (Fun f X)" "wf⇩t⇩r⇩m (Fun f X)" by auto
hence "wt⇩s⇩u⇩b⇩s⇩t (subst v (Fun f X))"
and *: "∀(v, t) ∈ set ((v,(Fun f X))#B). Γ (Var v) = Γ t"
"⋀t t'. (t,t') ∈ set E ⟹ Γ t = Γ t'"
using "4.prems"(2,3) unfolding wt⇩s⇩u⇩b⇩s⇩t_def subst_def by auto
have "v ∉ fv (Fun f X)" using "4.prems"(1) by force
hence **: "Unification.unify (subst_list (subst v (Fun f X)) E) ((v, (Fun f X))#B) = Some U"
using Unification.unify.simps(3)[of v "Fun f X" E B] "4.prems"(1) by auto
have "∀(s, t) ∈ set (subst_list (subst v (Fun f X)) E). wf⇩t⇩r⇩m s ∧ wf⇩t⇩r⇩m t"
using wf_trm_subst_singleton[OF _ ‹wf⇩t⇩r⇩m (Fun f X)›] "4.prems"(2)
unfolding subst_list_def subst_def by auto
moreover have "∀(s, t) ∈ set (subst_list (subst v (Fun f X)) E). Γ s = Γ t"
using *(2)[THEN wt_subst_trm'[OF ‹wt⇩s⇩u⇩b⇩s⇩t (subst v (Fun f X))›]] by (simp add: subst_list_def)
ultimately show ?case using "4.IH"[OF ‹v ∉ fv (Fun f X)› ** _ *(1)] by auto
qed auto
lemma mgu_wt_if_same_type:
assumes "mgu s t = Some σ" "wf⇩t⇩r⇩m s" "wf⇩t⇩r⇩m t" "Γ s = Γ t"
shows "wt⇩s⇩u⇩b⇩s⇩t σ"
proof -
let ?fv_disj = "λv t S. ¬(∃(v',t') ∈ S - {(v,t)}. (insert v (fv t)) ∩ (insert v' (fv t')) ≠ {})"
from assms(1) obtain σ' where "Unification.unify [(s,t)] [] = Some σ'" "subst_of σ' = σ"
by (auto split: option.splits)
hence "∀(v,t) ∈ set σ'. Γ (Var v) = Γ t" "distinct (map fst σ')"
using assms(2,3,4) unify_list_wt_if_same_type unify_list_distinct[of "[(s,t)]"] by auto
thus "wt⇩s⇩u⇩b⇩s⇩t σ" using ‹subst_of σ' = σ› unfolding wt⇩s⇩u⇩b⇩s⇩t_def
proof (induction σ' arbitrary: σ rule: List.rev_induct)
case (snoc tt σ' σ)
then obtain v t where tt: "tt = (v,t)" by (metis surj_pair)
hence σ: "σ = subst v t ∘⇩s subst_of σ'" using snoc.prems(3) by simp
have "∀(v,t) ∈ set σ'. Γ (Var v) = Γ t" "distinct (map fst σ')" using snoc.prems(1,2) by auto
then obtain σ'' where σ'': "subst_of σ' = σ''" "∀v. Γ (Var v) = Γ (σ'' v)" by (metis snoc.IH)
hence "Γ t = Γ (t ⋅ σ'')" for t using wt_subst_trm by blast
hence "Γ (Var v) = Γ (σ'' v)" "Γ t = Γ (t ⋅ σ'')" using σ''(2) by auto
moreover have "Γ (Var v) = Γ t" using snoc.prems(1) tt by simp
moreover have σ2: "σ = Var(v := t) ∘⇩s σ'' " using σ σ''(1) unfolding subst_def by simp
ultimately have "Γ (Var v) = Γ (σ v)" unfolding subst_compose_def by simp
have "subst_domain (subst v t) ⊆ {v}" unfolding subst_def by (auto simp add: subst_domain_def)
hence *: "subst_domain σ ⊆ insert v (subst_domain σ'')"
using tt σ σ''(1) snoc.prems(2) subst_domain_compose[of _ σ'']
by (auto simp add: subst_domain_def)
have "v ∉ set (map fst σ')" using tt snoc.prems(2) by auto
hence "v ∉ subst_domain σ''" using σ''(1) subst_of_dom_subset[of σ'] by auto
{ fix w assume "w ∈ subst_domain σ''"
hence "σ w = σ'' w" using σ2 σ''(1) ‹v ∉ subst_domain σ''› unfolding subst_compose_def by auto
hence "Γ (Var w) = Γ (σ w)" using σ''(2) by simp
}
thus ?case using ‹Γ (Var v) = Γ (σ v)› * by force
qed simp
qed
lemma wt_Unifier_if_Unifier:
assumes s_t: "wf⇩t⇩r⇩m s" "wf⇩t⇩r⇩m t" "Γ s = Γ t"
and δ: "Unifier δ s t"
shows "∃θ. Unifier θ s t ∧ wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range θ)"
using mgu_always_unifies[OF δ] mgu_gives_MGU[THEN MGU_is_Unifier[of s _ t]]
mgu_wt_if_same_type[OF _ s_t] mgu_wf_trm[OF _ s_t(1,2)] wf_trm_subst_range_iff
by fast
end
subsection ‹Automatically Proving Type-Flaw Resistance›
subsubsection ‹Definitions: Variable Renaming›
abbreviation "max_var t ≡ Max (insert 0 (snd ` fv t))"
abbreviation "max_var_set X ≡ Max (insert 0 (snd ` X))"
definition "var_rename n v ≡ Var (fst v, snd v + Suc n)"
definition "var_rename_inv n v ≡ Var (fst v, snd v - Suc n)"
subsubsection ‹Definitions: Computing a Finite Representation of the Sub-Message Patterns›
text ‹A sufficient requirement for a term to be a well-typed instance of another term›
definition is_wt_instance_of_cond where
"is_wt_instance_of_cond Γ t s ≡ (
Γ t = Γ s ∧ (case mgu t s of
None ⇒ False
| Some δ ⇒ inj_on δ (fv t) ∧ (∀x ∈ fv t. is_Var (δ x))))"
definition has_all_wt_instances_of where
"has_all_wt_instances_of Γ N M ≡ ∀t ∈ N. ∃s ∈ M. is_wt_instance_of_cond Γ t s"
text ‹This function computes a finite representation of the set of sub-message patterns›
definition SMP0 where
"SMP0 Ana Γ M ≡ let
f = λt. Fun (the_Fun (Γ t)) (map Var (zip (args (Γ t)) [0..<length (args (Γ t))]));
g = λM'. map f (filter (λt. is_Var t ∧ is_Fun (Γ t)) M')@
concat (map (fst ∘ Ana) M')@concat (map subterms_list M');
h = remdups ∘ g
in while (λA. set (h A) ≠ set A) h M"
text ‹These definitions are useful to refine an SMP representation set›
fun generalize_term where
"generalize_term _ _ n (Var x) = (Var x, n)"
| "generalize_term Γ p n (Fun f T) = (let τ = Γ (Fun f T)
in if p τ then (Var (τ, n), Suc n)
else let (T',n') = foldr (λt (S,m). let (t',m') = generalize_term Γ p m t in (t'#S,m'))
T ([],n)
in (Fun f T', n'))"
definition generalize_terms where
"generalize_terms Γ p ≡ map (fst ∘ generalize_term Γ p 0)"
definition remove_superfluous_terms where
"remove_superfluous_terms Γ T ≡
let
f = λS t R. ∃s ∈ set S - R. s ≠ t ∧ is_wt_instance_of_cond Γ t s;
g = λS t (U,R). if f S t R then (U, insert t R) else (t#U, R);
h = λS. remdups (fst (foldr (g S) S ([],{})))
in while (λS. h S ≠ S) h T"
subsubsection ‹Definitions: Checking Type-Flaw Resistance›
definition is_TComp_var_instance_closed where
"is_TComp_var_instance_closed Γ M ≡ ∀x ∈ fv⇩s⇩e⇩t (set M). is_Fun (Γ (Var x)) ⟶
list_ex (λt. is_Fun t ∧ Γ t = Γ (Var x) ∧ list_all is_Var (args t) ∧ distinct (args t)) M"
definition finite_SMP_representation where
"finite_SMP_representation arity Ana Γ M ≡
list_all (wf⇩t⇩r⇩m' arity) M ∧
has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M) ∧
has_all_wt_instances_of Γ (⋃((set ∘ fst ∘ Ana) ` set M)) (set M) ∧
is_TComp_var_instance_closed Γ M"
definition comp_tfr⇩s⇩e⇩t where
"comp_tfr⇩s⇩e⇩t arity Ana Γ M ≡
finite_SMP_representation arity Ana Γ M ∧
(let δ = var_rename (max_var_set (fv⇩s⇩e⇩t (set M)))
in ∀s ∈ set M. ∀t ∈ set M. is_Fun s ∧ is_Fun t ∧ Γ s ≠ Γ t ⟶ mgu s (t ⋅ δ) = None)"
fun comp_tfr⇩s⇩t⇩p where
"comp_tfr⇩s⇩t⇩p Γ (⟨_: t ≐ t'⟩⇩s⇩t) = (mgu t t' ≠ None ⟶ Γ t = Γ t')"
| "comp_tfr⇩s⇩t⇩p Γ (∀X⟨∨≠: F⟩⇩s⇩t) = (
(∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. is_Var (Γ (Var x))) ∨
(∀u ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F).
is_Fun u ⟶ (args u = [] ∨ (∃s ∈ set (args u). s ∉ Var ` set X))))"
| "comp_tfr⇩s⇩t⇩p _ _ = True"
definition comp_tfr⇩s⇩t where
"comp_tfr⇩s⇩t arity Ana Γ M S ≡
list_all (comp_tfr⇩s⇩t⇩p Γ) S ∧
list_all (wf⇩t⇩r⇩m' arity) (trms_list⇩s⇩t S) ∧
has_all_wt_instances_of Γ (trms⇩s⇩t S) (set M) ∧
comp_tfr⇩s⇩e⇩t arity Ana Γ M"
subsubsection ‹Small Lemmata›
lemma less_Suc_max_var_set:
assumes z: "z ∈ X"
and X: "finite X"
shows "snd z < Suc (max_var_set X)"
proof -
have "snd z ∈ snd ` X" using z by simp
hence "snd z ≤ Max (insert 0 (snd ` X))" using X by simp
thus ?thesis using X by simp
qed
lemma (in typed_model) finite_SMP_representationD:
assumes "finite_SMP_representation arity Ana Γ M"
shows "wf⇩t⇩r⇩m⇩s (set M)"
and "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
and "has_all_wt_instances_of Γ (⋃((set ∘ fst ∘ Ana) ` set M)) (set M)"
and "is_TComp_var_instance_closed Γ M"
using assms unfolding finite_SMP_representation_def list_all_iff wf⇩t⇩r⇩m_code by blast+
lemma (in typed_model) is_wt_instance_of_condD:
assumes t_instance_s: "is_wt_instance_of_cond Γ t s"
obtains δ where
"Γ t = Γ s" "mgu t s = Some δ"
"inj_on δ (fv t)" "δ ` (fv t) ⊆ range Var"
using t_instance_s unfolding is_wt_instance_of_cond_def Let_def by (cases "mgu t s") fastforce+
lemma (in typed_model) is_wt_instance_of_condD':
assumes t_wf_trm: "wf⇩t⇩r⇩m t"
and s_wf_trm: "wf⇩t⇩r⇩m s"
and t_instance_s: "is_wt_instance_of_cond Γ t s"
shows "∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = s ⋅ δ"
proof -
obtain δ where s:
"Γ t = Γ s" "mgu t s = Some δ"
"inj_on δ (fv t)" "δ ` (fv t) ⊆ range Var"
by (metis is_wt_instance_of_condD[OF t_instance_s])
have 0: "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m s" using s(1) t_wf_trm s_wf_trm by auto
note 1 = mgu_wt_if_same_type[OF s(2) 0 s(1)]
note 2 = conjunct1[OF mgu_gives_MGU[OF s(2)]]
show ?thesis
using s(1) inj_var_ran_unifiable_has_subst_match[OF 2 s(3,4)]
wt_subst_compose[OF 1 subst_var_inv_wt[OF 1, of "fv t"]]
wf_trms_subst_compose[OF mgu_wf_trms[OF s(2) 0] subst_var_inv_wf_trms[of δ "fv t"]]
by auto
qed
lemma (in typed_model) is_wt_instance_of_condD'':
assumes s_wf_trm: "wf⇩t⇩r⇩m s"
and t_instance_s: "is_wt_instance_of_cond Γ t s"
and t_var: "t = Var x"
shows "∃y. s = Var y ∧ Γ (Var y) = Γ (Var x)"
proof -
obtain δ where δ: "wt⇩s⇩u⇩b⇩s⇩t δ" and s: "Var x = s ⋅ δ"
using is_wt_instance_of_condD'[OF _ s_wf_trm t_instance_s] t_var by auto
obtain y where y: "s = Var y" using s by (cases s) auto
show ?thesis using wt_subst_trm''[OF δ] s y by metis
qed
lemma (in typed_model) has_all_wt_instances_ofD:
assumes N_instance_M: "has_all_wt_instances_of Γ N M"
and t_in_N: "t ∈ N"
obtains s δ where
"s ∈ M" "Γ t = Γ s" "mgu t s = Some δ"
"inj_on δ (fv t)" "δ ` (fv t) ⊆ range Var"
by (metis t_in_N N_instance_M is_wt_instance_of_condD has_all_wt_instances_of_def)
lemma (in typed_model) has_all_wt_instances_ofD':
assumes N_wf_trms: "wf⇩t⇩r⇩m⇩s N"
and M_wf_trms: "wf⇩t⇩r⇩m⇩s M"
and N_instance_M: "has_all_wt_instances_of Γ N M"
and t_in_N: "t ∈ N"
shows "∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t ∈ M ⋅⇩s⇩e⇩t δ"
using assms is_wt_instance_of_condD' unfolding has_all_wt_instances_of_def by fast
lemma (in typed_model) has_all_wt_instances_ofD'':
assumes N_wf_trms: "wf⇩t⇩r⇩m⇩s N"
and M_wf_trms: "wf⇩t⇩r⇩m⇩s M"
and N_instance_M: "has_all_wt_instances_of Γ N M"
and t_in_N: "Var x ∈ N"
shows "∃y. Var y ∈ M ∧ Γ (Var y) = Γ (Var x)"
using assms is_wt_instance_of_condD'' unfolding has_all_wt_instances_of_def by fast
lemma (in typed_model) has_all_instances_of_if_subset:
assumes "N ⊆ M"
shows "has_all_wt_instances_of Γ N M"
using assms inj_onI mgu_same_empty
unfolding has_all_wt_instances_of_def is_wt_instance_of_cond_def
by (smt option.case_eq_if option.discI option.sel subsetD term.discI(1) term.inject(1))
lemma (in typed_model) SMP_I':
assumes N_wf_trms: "wf⇩t⇩r⇩m⇩s N"
and M_wf_trms: "wf⇩t⇩r⇩m⇩s M"
and N_instance_M: "has_all_wt_instances_of Γ N M"
and t_in_N: "t ∈ N"
shows "t ∈ SMP M"
using has_all_wt_instances_ofD'[OF N_wf_trms M_wf_trms N_instance_M t_in_N]
SMP.Substitution[OF SMP.MP[of _ M]]
by blast
subsubsection ‹Lemma: Proving Type-Flaw Resistance›
locale typed_model' = typed_model arity public Ana Γ
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
⇒ (('fun,(('fun,'atom) term_type × nat)) term list
× ('fun,(('fun,'atom) term_type × nat)) term list)"
and Γ::"('fun,(('fun,'atom) term_type × nat)) term ⇒ ('fun,'atom) term_type"
+
assumes Γ_Var_fst: "⋀τ n m. Γ (Var (τ,n)) = Γ (Var (τ,m))"
and Ana_const: "⋀c T. arity c = 0 ⟹ Ana (Fun c T) = ([],[])"
and Ana_subst'_or_Ana_keys_subterm:
"(∀f T δ K R. Ana (Fun f T) = (K,R) ⟶ Ana (Fun f T ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ,R ⋅⇩l⇩i⇩s⇩t δ)) ∨
(∀t K R k. Ana t = (K,R) ⟶ k ∈ set K ⟶ k ⊏ t)"
begin
lemma var_rename_inv_comp: "t ⋅ (var_rename n ∘⇩s var_rename_inv n) = t"
proof (induction t)
case (Fun f T)
hence "map (λt. t ⋅ var_rename n ∘⇩s var_rename_inv n) T = T" by (simp add: map_idI)
thus ?case by (metis subst_apply_term.simps(2))
qed (simp add: var_rename_def var_rename_inv_def)
lemma var_rename_fv_disjoint:
"fv s ∩ fv (t ⋅ var_rename (max_var s)) = {}"
proof -
have 1: "∀v ∈ fv s. snd v ≤ max_var s" by simp
have 2: "∀v ∈ fv (t ⋅ var_rename n). snd v > n" for n unfolding var_rename_def by (induct t) auto
show ?thesis using 1 2 by force
qed
lemma var_rename_fv_set_disjoint:
assumes "finite M" "s ∈ M"
shows "fv s ∩ fv (t ⋅ var_rename (max_var_set (fv⇩s⇩e⇩t M))) = {}"
proof -
have 1: "∀v ∈ fv s. snd v ≤ max_var_set (fv⇩s⇩e⇩t M)" using assms
proof (induction M rule: finite_induct)
case (insert t M) thus ?case
proof (cases "t = s")
case False
hence "∀v ∈ fv s. snd v ≤ max_var_set (fv⇩s⇩e⇩t M)" using insert by simp
moreover have "max_var_set (fv⇩s⇩e⇩t M) ≤ max_var_set (fv⇩s⇩e⇩t (insert t M))"
using insert.hyps(1) insert.prems
by force
ultimately show ?thesis by auto
qed simp
qed simp
have 2: "∀v ∈ fv (t ⋅ var_rename n). snd v > n" for n unfolding var_rename_def by (induct t) auto
show ?thesis using 1 2 by force
qed
lemma var_rename_fv_set_disjoint':
assumes "finite M"
shows "fv⇩s⇩e⇩t M ∩ fv⇩s⇩e⇩t (N ⋅⇩s⇩e⇩t var_rename (max_var_set (fv⇩s⇩e⇩t M))) = {}"
using var_rename_fv_set_disjoint[OF assms] by auto
lemma var_rename_is_renaming[simp]:
"subst_range (var_rename n) ⊆ range Var"
"subst_range (var_rename_inv n) ⊆ range Var"
unfolding var_rename_def var_rename_inv_def by auto
lemma var_rename_wt[simp]:
"wt⇩s⇩u⇩b⇩s⇩t (var_rename n)"
"wt⇩s⇩u⇩b⇩s⇩t (var_rename_inv n)"
by (auto simp add: var_rename_def var_rename_inv_def wt⇩s⇩u⇩b⇩s⇩t_def Γ_Var_fst)
lemma var_rename_wt':
assumes "wt⇩s⇩u⇩b⇩s⇩t δ" "s = m ⋅ δ"
shows "wt⇩s⇩u⇩b⇩s⇩t (var_rename_inv n ∘⇩s δ)" "s = m ⋅ var_rename n ⋅ var_rename_inv n ∘⇩s δ"
using assms(2) wt_subst_compose[OF var_rename_wt(2)[of n] assms(1)] var_rename_inv_comp[of m n]
by force+
lemma var_rename_wf⇩t⇩r⇩m⇩s_range[simp]:
"wf⇩t⇩r⇩m⇩s (subst_range (var_rename n))"
"wf⇩t⇩r⇩m⇩s (subst_range (var_rename_inv n))"
using var_rename_is_renaming by fastforce+
lemma Fun_range_case:
"(∀f T. Fun f T ∈ M ⟶ P f T) ⟷ (∀u ∈ M. case u of Fun f T ⇒ P f T | _ ⇒ True)"
"(∀f T. Fun f T ∈ M ⟶ P f T) ⟷ (∀u ∈ M. is_Fun u ⟶ P (the_Fun u) (args u))"
by (auto split: "term.splits")
lemma is_TComp_var_instance_closedD:
assumes x: "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var x) = Γ (Var y)" "Γ (Var x) = TComp f T"
and closed: "is_TComp_var_instance_closed Γ M"
shows "∃g U. Fun g U ∈ set M ∧ Γ (Fun g U) = Γ (Var x) ∧ (∀u ∈ set U. is_Var u) ∧ distinct U"
using assms unfolding is_TComp_var_instance_closed_def list_all_iff list_ex_iff by fastforce
lemma is_TComp_var_instance_closedD':
assumes "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var x) = Γ (Var y)" "TComp f T ⊑ Γ (Var x)"
and closed: "is_TComp_var_instance_closed Γ M"
and wf: "wf⇩t⇩r⇩m⇩s (set M)"
shows "∃g U. Fun g U ∈ set M ∧ Γ (Fun g U) = TComp f T ∧ (∀u ∈ set U. is_Var u) ∧ distinct U"
using assms(1,2)
proof (induction "Γ (Var x)" arbitrary: x)
case (Fun g U)
note IH = Fun.hyps(1)
have g: "arity g > 0" "public g" using Fun.hyps(2) fun_type_inv[of "Var x"] Γ_Var_fst by simp_all
then obtain V where V:
"Fun g V ∈ set M" "Γ (Fun g V) = Γ (Var x)" "∀v ∈ set V. ∃x. v = Var x"
"distinct V" "length U = length V"
using is_TComp_var_instance_closedD[OF Fun.prems(1) Fun.hyps(2)[symmetric] closed(1)]
by (metis Fun.hyps(2) fun_type_id_eq fun_type_length_eq is_VarE)
hence U: "U = map Γ V" using fun_type[OF g(1), of V] Fun.hyps(2) by simp
hence 1: "Γ v ∈ set U" when v: "v ∈ set V" for v using v by simp
have 2: "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var z) = Γ (Var y)" when z: "Var z ∈ set V" for z
using V(1) fv_subset_subterms Fun_param_in_subterms[OF z] by fastforce
show ?case
proof (cases "TComp f T = Γ (Var x)")
case False
then obtain u where u: "u ∈ set U" "TComp f T ⊑ u"
using Fun.prems(2) Fun.hyps(2) by moura
then obtain y where y: "Var y ∈ set V" "Γ (Var y) = u" using U V(3) Γ_Var_fst by auto
show ?thesis using IH[OF _ 2[OF y(1)]] u y(2) by metis
qed (use V in fastforce)
qed simp
lemma TComp_var_instance_wt_subst_exists:
assumes gT: "Γ (Fun g T) = TComp g (map Γ U)" "wf⇩t⇩r⇩m (Fun g T)"
and U: "∀u ∈ set U. ∃y. u = Var y" "distinct U"
shows "∃θ. wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range θ) ∧ Fun g T = Fun g U ⋅ θ"
proof -
define the_i where "the_i ≡ λy. THE x. x < length U ∧ U ! x = Var y"
define θ where θ: "θ ≡ λy. if Var y ∈ set U then T ! the_i y else Var y"
have g: "arity g > 0" using gT(1,2) fun_type_inv(1) by blast
have UT: "length U = length T" using fun_type_length_eq gT(1) by fastforce
have 1: "the_i y < length U ∧ U ! the_i y = Var y" when y: "Var y ∈ set U" for y
using theI'[OF distinct_Ex1[OF U(2) y]] unfolding the_i_def by simp
have 2: "wt⇩s⇩u⇩b⇩s⇩t θ"
using θ 1 gT(1) fun_type[OF g] UT
unfolding wt⇩s⇩u⇩b⇩s⇩t_def
by (metis (no_types, lifting) nth_map term.inject(2))
have "∀i<length T. U ! i ⋅ θ = T ! i"
using θ 1 U(1) UT distinct_Ex1[OF U(2)] in_set_conv_nth
by (metis (no_types, lifting) subst_apply_term.simps(1))
hence "T = map (λt. t ⋅ θ) U" by (simp add: UT nth_equalityI)
hence 3: "Fun g T = Fun g U ⋅ θ" by simp
have "subst_range θ ⊆ set T" using θ 1 U(1) UT by (auto simp add: subst_domain_def)
hence 4: "wf⇩t⇩r⇩m⇩s (subst_range θ)" using gT(2) wf_trm_param by auto
show ?thesis by (metis 2 3 4)
qed
lemma TComp_var_instance_closed_has_Var:
assumes closed: "is_TComp_var_instance_closed Γ M"
and wf_M: "wf⇩t⇩r⇩m⇩s (set M)"
and wf_δx: "wf⇩t⇩r⇩m (δ x)"
and y_ex: "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var x) = Γ (Var y)"
and t: "t ⊑ δ x"
and δ_wt: "wt⇩s⇩u⇩b⇩s⇩t δ"
shows "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var y) = Γ t"
proof (cases "Γ (Var x)")
case (Var a)
hence "t = δ x"
using t wf_δx δ_wt
by (metis (full_types) const_type_inv_wf fun_if_subterm subtermeq_Var_const(2) wt⇩s⇩u⇩b⇩s⇩t_def)
thus ?thesis using y_ex wt_subst_trm''[OF δ_wt, of "Var x"] by fastforce
next
case (Fun f T)
hence Γ_δx: "Γ (δ x) = TComp f T" using wt_subst_trm''[OF δ_wt, of "Var x"] by auto
show ?thesis
proof (cases "t = δ x")
case False
hence t_subt_δx: "t ⊏ δ x" using t(1) Γ_δx by fastforce
obtain T' where T': "δ x = Fun f T'" using Γ_δx t_subt_δx fun_type_id_eq by (cases "δ x") auto
obtain g S where gS: "Fun g S ⊑ δ x" "t ∈ set S" using Fun_ex_if_subterm[OF t_subt_δx] by blast
have gS_wf: "wf⇩t⇩r⇩m (Fun g S)" by (rule wf_trm_subtermeq[OF wf_δx gS(1)])
hence "arity g > 0" using gS(2) by (metis length_pos_if_in_set wf_trm_arity)
hence gS_Γ: "Γ (Fun g S) = TComp g (map Γ S)" using fun_type by blast
obtain h U where hU:
"Fun h U ∈ set M" "Γ (Fun h U) = Fun g (map Γ S)" "∀u ∈ set U. is_Var u"
using is_TComp_var_instance_closedD'[OF y_ex _ closed wf_M]
subtermeq_imp_subtermtypeeq[OF wf_δx] gS Γ_δx Fun gS_Γ
by metis
obtain y where y: "Var y ∈ set U" "Γ (Var y) = Γ t"
using hU(3) fun_type_param_ex[OF hU(2) gS(2)] by fast
have "y ∈ fv⇩s⇩e⇩t (set M)" using hU(1) y(1) by force
thus ?thesis using y(2) closed by metis
qed (metis y_ex Fun Γ_δx)
qed
lemma TComp_var_instance_closed_has_Fun:
assumes closed: "is_TComp_var_instance_closed Γ M"
and wf_M: "wf⇩t⇩r⇩m⇩s (set M)"
and wf_δx: "wf⇩t⇩r⇩m (δ x)"
and y_ex: "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var x) = Γ (Var y)"
and t: "t ⊑ δ x"
and δ_wt: "wt⇩s⇩u⇩b⇩s⇩t δ"
and t_Γ: "Γ t = TComp g T"
and t_fun: "is_Fun t"
shows "∃m ∈ set M. ∃θ. wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range θ) ∧ t = m ⋅ θ ∧ is_Fun m"
proof -
obtain T'' where T'': "t = Fun g T''" using t_Γ t_fun fun_type_id_eq by blast
have g: "arity g > 0" using t_Γ fun_type_inv[of t] by simp_all
have "TComp g T ⊑ Γ (Var x)" using δ_wt t t_Γ
by (metis wf_δx subtermeq_imp_subtermtypeeq wt⇩s⇩u⇩b⇩s⇩t_def)
then obtain U where U:
"Fun g U ∈ set M" "Γ (Fun g U) = TComp g T" "∀u ∈ set U. ∃y. u = Var y"
"distinct U" "length T'' = length U"
using is_TComp_var_instance_closedD'[OF y_ex _ closed wf_M]
by (metis t_Γ T'' fun_type_id_eq fun_type_length_eq is_VarE)
hence UT': "T = map Γ U" using fun_type[OF g, of U] by simp
show ?thesis
using TComp_var_instance_wt_subst_exists UT' T'' U(1,3,4) t t_Γ wf_δx wf_trm_subtermeq
by (metis term.disc(2))
qed
lemma TComp_var_and_subterm_instance_closed_has_subterms_instances:
assumes M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
and M_subterms_cl: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
and M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
and t: "t ⊑⇩s⇩e⇩t set M"
and s: "s ⊑ t ⋅ δ"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "∃m ∈ set M. ∃θ. wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range θ) ∧ s = m ⋅ θ"
using subterm_subst_unfold[OF s]
proof
assume "∃s'. s' ⊑ t ∧ s = s' ⋅ δ"
then obtain s' where s': "s' ⊑ t" "s = s' ⋅ δ" by blast
then obtain θ where θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "s' ∈ set M ⋅⇩s⇩e⇩t θ"
using t has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]
term.order_trans[of s' t]
by blast
then obtain m where m: "m ∈ set M" "s' = m ⋅ θ" by blast
have "s = m ⋅ (θ ∘⇩s δ)" using s'(2) m(2) by simp
thus ?thesis
using m(1) wt_subst_compose[OF θ(1) δ(1)] wf_trms_subst_compose[OF θ(2) δ(2)] by blast
next
assume "∃x ∈ fv t. s ⊏ δ x"
then obtain x where x: "x ∈ fv t" "s ⊏ δ x" "s ⊑ δ x" by blast
note 0 = TComp_var_instance_closed_has_Var[OF M_var_inst_cl M_wf]
note 1 = has_all_wt_instances_ofD''[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]
have δx_wf: "wf⇩t⇩r⇩m (δ x)" and s_wf_trm: "wf⇩t⇩r⇩m s"
using δ(2) wf_trm_subterm[OF _ x(2)] by fastforce+
have x_fv_ex: "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var x) = Γ (Var y)"
using x(1) s fv_subset_subterms[OF t] by auto
obtain y where y: "y ∈ fv⇩s⇩e⇩t (set M)" "Γ (Var y) = Γ s"
using 0[of δ x s, OF δx_wf x_fv_ex x(3) δ(1)] by metis
then obtain z where z: "Var z ∈ set M" "Γ (Var z) = Γ s"
using 1[of y] vars_iff_subtermeq_set[of y "set M"] by metis
define θ where "θ ≡ Var(z := s)::('fun, ('fun, 'atom) term × nat) subst"
have "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "s = Var z ⋅ θ"
using z(2) s_wf_trm unfolding θ_def wt⇩s⇩u⇩b⇩s⇩t_def by force+
thus ?thesis using z(1) by blast
qed
context
begin
private lemma SMP_D_aux1:
assumes "t ∈ SMP (set M)"
and closed: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
"is_TComp_var_instance_closed Γ M"
and wf_M: "wf⇩t⇩r⇩m⇩s (set M)"
shows "∀x ∈ fv t. ∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var y) = Γ (Var x)"
using assms(1)
proof (induction t rule: SMP.induct)
case (MP t) show ?case
proof
fix x assume x: "x ∈ fv t"
hence "Var x ∈ subterms⇩s⇩e⇩t (set M)" using MP.hyps vars_iff_subtermeq by fastforce
then obtain δ s where δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
and s: "s ∈ set M" "Var x = s ⋅ δ"
using has_all_wt_instances_ofD'[OF wf_trms_subterms[OF wf_M] wf_M closed(1)] by blast
then obtain y where y: "s = Var y" by (cases s) auto
thus "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var y) = Γ (Var x)"
using s wt_subst_trm''[OF δ(1), of "Var y"] by force
qed
next
case (Subterm t t')
hence "fv t' ⊆ fv t" using subtermeq_vars_subset by auto
thus ?case using Subterm.IH by auto
next
case (Substitution t δ)
note IH = Substitution.IH
show ?case
proof
fix x assume x: "x ∈ fv (t ⋅ δ)"
then obtain y where y: "y ∈ fv t" "Γ (Var x) ⊑ Γ (Var y)"
using Substitution.hyps(2,3)
by (metis subst_apply_img_var subtermeqI' subtermeq_imp_subtermtypeeq
vars_iff_subtermeq wt⇩s⇩u⇩b⇩s⇩t_def wf_trm_subst_rangeD)
let ?P = "λx. ∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var y) = Γ (Var x)"
show "?P x" using y IH
proof (induction "Γ (Var y)" arbitrary: y t)
case (Var a)
hence "Γ (Var x) = Γ (Var y)" by auto
thus ?case using Var(2,4) by auto
next
case (Fun f T)
obtain z where z: "∃w ∈ fv⇩s⇩e⇩t (set M). Γ (Var z) = Γ (Var w)" "Γ (Var z) = Γ (Var y)"
using Fun.prems(1,3) by blast
show ?case
proof (cases "Γ (Var x) = Γ (Var y)")
case True thus ?thesis using Fun.prems by auto
next
case False
then obtain τ where τ: "τ ∈ set T" "Γ (Var x) ⊑ τ" using Fun.prems(2) Fun.hyps(2) by auto
then obtain U where U:
"Fun f U ∈ set M" "Γ (Fun f U) = Γ (Var z)" "∀u ∈ set U. ∃v. u = Var v" "distinct U"
using is_TComp_var_instance_closedD'[OF z(1) _ closed(2) wf_M] Fun.hyps(2) z(2)
by (metis fun_type_id_eq subtermeqI' is_VarE)
hence 1: "∀x ∈ fv (Fun f U). ∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var y) = Γ (Var x)" by force
have "arity f > 0" using U(2) z(2) Fun.hyps(2) fun_type_inv(1) by metis
hence "Γ (Fun f U) = TComp f (map Γ U)" using fun_type by auto
then obtain u where u: "Var u ∈ set U" "Γ (Var u) = τ"
using τ(1) U(2,3) z(2) Fun.hyps(2) by auto
show ?thesis
using Fun.hyps(1)[of u "Fun f U"] u τ 1
by force
qed
qed
qed
next
case (Ana t K T k)
have "fv k ⊆ fv t" using Ana_keys_fv[OF Ana.hyps(2)] Ana.hyps(3) by auto
thus ?case using Ana.IH by auto
qed
private lemma SMP_D_aux2:
fixes t::"('fun, ('fun, 'atom) term × nat) term"
assumes t_SMP: "t ∈ SMP (set M)"
and t_Var: "∃x. t = Var x"
and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
shows "∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = m ⋅ δ"
proof -
have M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
and M_subterms_cl: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
and M_Ana_cl: "has_all_wt_instances_of Γ (⋃((set ∘ fst ∘ Ana) ` set M)) (set M)"
using finite_SMP_representationD[OF M_SMP_repr] by blast+
have M_Ana_wf: "wf⇩t⇩r⇩m⇩s (⋃ ((set ∘ fst ∘ Ana) ` set M))"
proof
fix k assume "k ∈ ⋃((set ∘ fst ∘ Ana) ` set M)"
then obtain m where m: "m ∈ set M" "k ∈ set (fst (Ana m))" by force
thus "wf⇩t⇩r⇩m k" using M_wf Ana_keys_wf'[of m "fst (Ana m)" _ k] surjective_pairing by blast
qed
note 0 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]
note 1 = has_all_wt_instances_ofD'[OF M_Ana_wf M_wf M_Ana_cl]
obtain x y where x: "t = Var x" and y: "y ∈ fv⇩s⇩e⇩t (set M)" "Γ (Var y) = Γ (Var x)"
using t_Var SMP_D_aux1[OF t_SMP M_subterms_cl M_var_inst_cl M_wf] by fastforce
then obtain m δ where m: "m ∈ set M" "m ⋅ δ = Var y" and δ: "wt⇩s⇩u⇩b⇩s⇩t δ"
using 0[of "Var y"] vars_iff_subtermeq_set[of y "set M"] by fastforce
obtain z where z: "m = Var z" using m(2) by (cases m) auto
define θ where "θ ≡ Var(z := Var x)::('fun, ('fun, 'atom) term × nat) subst"
have "Γ (Var z) = Γ (Var x)" using y(2) m(2) z wt_subst_trm''[OF δ, of m] by argo
hence "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" unfolding θ_def wt⇩s⇩u⇩b⇩s⇩t_def by force+
moreover have "t = m ⋅ θ" using x z unfolding θ_def by simp
ultimately show ?thesis using m(1) by blast
qed
private lemma SMP_D_aux3:
assumes hyps: "t' ⊑ t" and wf_t: "wf⇩t⇩r⇩m t" and prems: "is_Fun t'"
and IH:
"((∃f. t = Fun f []) ∧ (∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = m ⋅ δ)) ∨
(∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = m ⋅ δ ∧ is_Fun m)"
and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
shows "((∃f. t' = Fun f []) ∧ (∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t' = m ⋅ δ)) ∨
(∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t' = m ⋅ δ ∧ is_Fun m)"
proof (cases "∃f. t = Fun f [] ∨ t' = Fun f []")
case True
have M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
and M_subterms_cl: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
and M_Ana_cl: "has_all_wt_instances_of Γ (⋃((set ∘ fst ∘ Ana) ` set M)) (set M)"
using finite_SMP_representationD[OF M_SMP_repr] by blast+
note 0 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl]
note 1 = TComp_var_instance_closed_has_Fun[OF M_var_inst_cl M_wf]
note 2 = TComp_var_and_subterm_instance_closed_has_subterms_instances[
OF M_var_inst_cl M_subterms_cl M_wf]
have wf_t': "wf⇩t⇩r⇩m t'" using hyps wf_t wf_trm_subterm by blast
obtain c where "t = Fun c [] ∨ t' = Fun c []" using True by moura
thus ?thesis
proof
assume c: "t' = Fun c []"
show ?thesis
proof (cases "∃f. t = Fun f []")
case True
hence "t = t'" using c hyps by force
thus ?thesis using IH by fast
next
case False
note F = this
then obtain m δ where m: "m ∈ set M" "t = m ⋅ δ"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using IH by blast
show ?thesis using subterm_subst_unfold[OF hyps[unfolded m(2)]]
proof
assume "∃m'. m' ⊑ m ∧ t' = m' ⋅ δ"
then obtain m' where m': "m' ⊑ m" "t' = m' ⋅ δ" by moura
obtain n θ where n: "n ∈ set M" "m' = n ⋅ θ" and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using 0[of m'] m(1) m'(1) by blast
have "t' = n ⋅ (θ ∘⇩s δ)" using m'(2) n(2) by auto
thus ?thesis
using c n(1) wt_subst_compose[OF θ(1) δ(1)] wf_trms_subst_compose[OF θ(2) δ(2)] by blast
next
assume "∃x ∈ fv m. t' ⊏ δ x"
then obtain x where x: "x ∈ fv m" "t' ⊏ δ x" "t' ⊑ δ x" by moura
have δx_wf: "wf⇩t⇩r⇩m (δ x)" using δ(2) by fastforce
have x_fv_ex: "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var x) = Γ (Var y)" using x m by auto
show ?thesis
proof (cases "Γ t'")
case (Var a)
show ?thesis
using c m 2[OF _ hyps[unfolded m(2)] δ]
by fast
next
case (Fun g S)
show ?thesis
using c 1[of δ x t', OF δx_wf x_fv_ex x(3) δ(1) Fun]
by blast
qed
qed
qed
qed (use IH hyps in simp)
next
case False
note F = False
then obtain m δ where m:
"m ∈ set M" "wt⇩s⇩u⇩b⇩s⇩t δ" "t = m ⋅ δ" "is_Fun m" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using IH by moura
obtain f T where fT: "t' = Fun f T" "arity f > 0" "Γ t' = TComp f (map Γ T)"
using F prems fun_type wf_trm_subtermeq[OF wf_t hyps]
by (metis is_FunE length_greater_0_conv subtermeqI' wf⇩t⇩r⇩m_def)
have closed: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
"is_TComp_var_instance_closed Γ M"
using M_SMP_repr unfolding finite_SMP_representation_def by metis+
have M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
using finite_SMP_representationD[OF M_SMP_repr] by blast
show ?thesis
proof (cases "∃x ∈ fv m. t' ⊑ δ x")
case True
then obtain x where x: "x ∈ fv m" "t' ⊑ δ x" by moura
have 1: "x ∈ fv⇩s⇩e⇩t (set M)" using m(1) x(1) by auto
have 2: "is_Fun (δ x)" using prems x(2) by auto
have 3: "wf⇩t⇩r⇩m (δ x)" using m(5) by (simp add: wf_trm_subst_rangeD)
have "¬(∃f. δ x = Fun f [])" using F x(2) by auto
hence "∃f T. Γ (Var x) = TComp f T" using 2 3 m(2)
by (metis (no_types) fun_type is_FunE length_greater_0_conv subtermeqI' wf⇩t⇩r⇩m_def wt⇩s⇩u⇩b⇩s⇩t_def)
moreover have "∃f T. Γ t' = Fun f T"
using False prems wf_trm_subtermeq[OF wf_t hyps]
by (metis (no_types) fun_type is_FunE length_greater_0_conv subtermeqI' wf⇩t⇩r⇩m_def)
ultimately show ?thesis
using TComp_var_instance_closed_has_Fun 1 x(2) m(2) prems closed 3 M_wf
by metis
next
case False
then obtain m' where m': "m' ⊑ m" "t' = m' ⋅ δ" "is_Fun m'"
using hyps m(3) subterm_subst_not_img_subterm
by blast
then obtain θ m'' where θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "m'' ∈ set M" "m' = m'' ⋅ θ"
using m(1) has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf closed(1)] by blast
hence t'_m'': "t' = m'' ⋅ θ ∘⇩s δ" using m'(2) by fastforce
note θδ = wt_subst_compose[OF θ(1) m(2)] wf_trms_subst_compose[OF θ(2) m(5)]
show ?thesis
proof (cases "is_Fun m''")
case True thus ?thesis using θ(3,4) m'(2,3) m(4) fT t'_m'' θδ by blast
next
case False
then obtain x where x: "m'' = Var x" by moura
hence "∃y ∈ fv⇩s⇩e⇩t (set M). Γ (Var x) = Γ (Var y)" "t' ⊑ (θ ∘⇩s δ) x"
"Γ (Var x) = Fun f (map Γ T)" "wf⇩t⇩r⇩m ((θ ∘⇩s δ) x)"
using θδ t'_m'' θ(3) fv_subset[OF θ(3)] fT(3) subst_apply_term.simps(1)[of x "θ ∘⇩s δ"]
wt_subst_trm''[OF θδ(1), of "Var x"]
by (fastforce, blast, argo, fastforce)
thus ?thesis
using x TComp_var_instance_closed_has_Fun[
of M "θ ∘⇩s δ" x t' f "map Γ T", OF closed(2) M_wf _ _ _ θδ(1) fT(3) prems]
by blast
qed
qed
qed
lemma SMP_D:
assumes "t ∈ SMP (set M)" "is_Fun t"
and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
shows "((∃f. t = Fun f []) ∧ (∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = m ⋅ δ)) ∨
(∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = m ⋅ δ ∧ is_Fun m)"
proof -
have wf_M: "wf⇩t⇩r⇩m⇩s (set M)"
and closed: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
"has_all_wt_instances_of Γ (⋃((set ∘ fst ∘ Ana) ` set M)) (set M)"
"is_TComp_var_instance_closed Γ M"
using finite_SMP_representationD[OF M_SMP_repr] by blast+
show ?thesis using assms(1,2)
proof (induction t rule: SMP.induct)
case (MP t)
moreover have "wt⇩s⇩u⇩b⇩s⇩t Var" "wf⇩t⇩r⇩m⇩s (subst_range Var)" "t = t ⋅ Var" by simp_all
ultimately show ?case by blast
next
case (Subterm t t')
hence t_fun: "is_Fun t" by auto
note * = Subterm.hyps(2) SMP_wf_trm[OF Subterm.hyps(1) wf_M(1)]
Subterm.prems Subterm.IH[OF t_fun] M_SMP_repr
show ?case by (rule SMP_D_aux3[OF *])
next
case (Substitution t δ)
have wf: "wf⇩t⇩r⇩m t" by (metis Substitution.hyps(1) wf_M(1) SMP_wf_trm)
hence wf': "wf⇩t⇩r⇩m (t ⋅ δ)" using Substitution.hyps(3) wf_trm_subst by blast
show ?case
proof (cases "Γ t")
case (Var a)
hence 1: "Γ (t ⋅ δ) = TAtom a" using Substitution.hyps(2) by (metis wt_subst_trm'')
then obtain c where c: "t ⋅ δ = Fun c []"
using TAtom_term_cases[OF wf' 1] Substitution.prems by fastforce
hence "(∃x. t = Var x) ∨ t = t ⋅ δ" by (cases t) auto
thus ?thesis
proof
assume t_Var: "∃x. t = Var x"
then obtain x where x: "t = Var x" "δ x = Fun c []" "Γ (Var x) = TAtom a"
using c 1 wt_subst_trm''[OF Substitution.hyps(2), of t] by force
obtain m θ where m: "m ∈ set M" "t = m ⋅ θ" and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using SMP_D_aux2[OF Substitution.hyps(1) t_Var M_SMP_repr] by moura
have "m ⋅ (θ ∘⇩s δ) = Fun c []" using c m(2) by auto
thus ?thesis
using c m(1) wt_subst_compose[OF θ(1) Substitution.hyps(2)]
wf_trms_subst_compose[OF θ(2) Substitution.hyps(3)]
by metis
qed (use c Substitution.IH in auto)
next
case (Fun f T)
hence 1: "Γ (t ⋅ δ) = TComp f T" using Substitution.hyps(2) by (metis wt_subst_trm'')
have 2: "¬(∃f. t = Fun f [])" using Fun TComp_term_cases[OF wf] by auto
obtain T'' where T'': "t ⋅ δ = Fun f T''"
using 1 2 fun_type_id_eq Fun Substitution.prems
by fastforce
have f: "arity f > 0" "public f" using fun_type_inv[OF 1] by metis+
show ?thesis
proof (cases t)
case (Fun g U)
then obtain m θ where m:
"m ∈ set M" "wt⇩s⇩u⇩b⇩s⇩t θ" "t = m ⋅ θ" "is_Fun m" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using Substitution.IH Fun 2 by moura
have "wt⇩s⇩u⇩b⇩s⇩t (θ ∘⇩s δ)" "t ⋅ δ = m ⋅ (θ ∘⇩s δ)" "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s δ))"
using wt_subst_compose[OF m(2) Substitution.hyps(2)] m(3)
wf_trms_subst_compose[OF m(5) Substitution.hyps(3)]
by auto
thus ?thesis using m(1,4) by metis
next
case (Var x)
then obtain y where y: "y ∈ fv⇩s⇩e⇩t (set M)" "Γ (Var y) = Γ (Var x)"
using SMP_D_aux1[OF Substitution.hyps(1) closed(1,3) wf_M] Fun
by moura
hence 3: "Γ (Var y) = TComp f T" using Var Fun Γ_Var_fst by simp
obtain h V where V:
"Fun h V ∈ set M" "Γ (Fun h V) = Γ (Var y)" "∀u ∈ set V. ∃z. u = Var z" "distinct V"
by (metis is_VarE is_TComp_var_instance_closedD[OF _ 3 closed(3)] y(1))
moreover have "length T'' = length V" using 3 V(2) fun_type_length_eq 1 T'' by metis
ultimately have TV: "T = map Γ V"
by (metis fun_type[OF f(1)] 3 fun_type_id_eq term.inject(2))
obtain θ where θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "t ⋅ δ = Fun h V ⋅ θ"
using TComp_var_instance_wt_subst_exists 1 3 T'' TV V(2,3,4) wf'
by (metis fun_type_id_eq)
have 9: "Γ (Fun h V) = Γ (δ x)" using y(2) Substitution.hyps(2) V(2) 1 3 Var by auto
show ?thesis using Var θ 9 V(1) by force
qed
qed
next
case (Ana t K T k)
have 1: "is_Fun t" using Ana.hyps(2,3) by auto
then obtain f U where U: "t = Fun f U" by moura
have 2: "fv k ⊆ fv t" using Ana_keys_fv[OF Ana.hyps(2)] Ana.hyps(3) by auto
have wf_t: "wf⇩t⇩r⇩m t"
using SMP_wf_trm[OF Ana.hyps(1)] wf⇩t⇩r⇩m_code wf_M
by auto
hence wf_k: "wf⇩t⇩r⇩m k"
using Ana_keys_wf'[OF Ana.hyps(2)] wf⇩t⇩r⇩m_code Ana.hyps(3)
by auto
have wf_M_keys: "wf⇩t⇩r⇩m⇩s (⋃((set ∘ fst ∘ Ana) ` set M))"
proof
fix t assume "t ∈ (⋃((set ∘ fst ∘ Ana) ` set M))"
then obtain s where s: "s ∈ set M" "t ∈ (set ∘ fst ∘ Ana) s" by blast
obtain K R where KR: "Ana s = (K,R)" by (metis surj_pair)
hence "t ∈ set K" using s(2) by simp
thus "wf⇩t⇩r⇩m t" using Ana_keys_wf'[OF KR] wf_M s(1) by blast
qed
show ?case using Ana_subst'_or_Ana_keys_subterm
proof
assume "∀t K T k. Ana t = (K, T) ⟶ k ∈ set K ⟶ k ⊏ t"
hence *: "k ⊑ t" using Ana.hyps(2,3) by auto
show ?thesis by (rule SMP_D_aux3[OF * wf_t Ana.prems Ana.IH[OF 1] M_SMP_repr])
next
assume Ana_subst':
"∀f T δ K M. Ana (Fun f T) = (K, M) ⟶ Ana (Fun f T ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ, M ⋅⇩l⇩i⇩s⇩t δ)"
have "arity f > 0" using Ana_const[of f U] U Ana.hyps(2,3) by fastforce
hence "U ≠ []" using wf_t U unfolding wf⇩t⇩r⇩m_def by force
then obtain m δ where m: "m ∈ set M" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" "t = m ⋅ δ" "is_Fun m"
using Ana.IH[OF 1] U by auto
hence "Ana (t ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ,T ⋅⇩l⇩i⇩s⇩t δ)" using Ana_subst' U Ana.hyps(2) by auto
obtain Km Tm where Ana_m: "Ana m = (Km,Tm)" by moura
hence "Ana (m ⋅ δ) = (Km ⋅⇩l⇩i⇩s⇩t δ,Tm ⋅⇩l⇩i⇩s⇩t δ)"
using Ana_subst' U m(4) is_FunE[OF m(5)] Ana.hyps(2)
by metis
then obtain km where km: "km ∈ set Km" "k = km ⋅ δ" using Ana.hyps(2,3) m(4) by auto
then obtain θ km' where θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and km': "km' ∈ set M" "km = km' ⋅ θ"
using Ana_m m(1) has_all_wt_instances_ofD'[OF wf_M_keys wf_M closed(2), of km] by force
have kθδ: "k = km' ⋅ θ ∘⇩s δ" "wt⇩s⇩u⇩b⇩s⇩t (θ ∘⇩s δ)" "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s δ))"
using km(2) km' wt_subst_compose[OF θ(1) m(2)] wf_trms_subst_compose[OF θ(2) m(3)]
by auto
show ?case
proof (cases "is_Fun km'")
case True thus ?thesis using kθδ km'(1) by blast
next
case False
note F = False
then obtain x where x: "km' = Var x" by auto
hence 3: "x ∈ fv⇩s⇩e⇩t (set M)" using fv_subset[OF km'(1)] by auto
obtain kf kT where kf: "k = Fun kf kT" using Ana.prems by auto
show ?thesis
proof (cases "kT = []")
case True thus ?thesis using kθδ(1) kθδ(2) kθδ(3) kf km'(1) by blast
next
case False
hence 4: "arity kf > 0" using wf_k kf TAtom_term_cases const_type by fastforce
then obtain kT' where kT': "Γ k = TComp kf kT'" by (simp add: fun_type kf)
then obtain V where V:
"Fun kf V ∈ set M" "Γ (Fun kf V) = Γ (Var x)" "∀u ∈ set V. ∃v. u = Var v"
"distinct V" "is_Fun (Fun kf V)"
using is_TComp_var_instance_closedD[OF _ _ closed(3), of x]
x m(2) kθδ(1) 3 wt_subst_trm''[OF kθδ(2)]
by (metis fun_type_id_eq term.disc(2) is_VarE)
have 5: "kT' = map Γ V"
using fun_type[OF 4] x kT' kθδ m(2) V(2)
by (metis term.inject(2) wt_subst_trm'')
thus ?thesis
using TComp_var_instance_wt_subst_exists wf_k kf 4 V(3,4) kT' V(1,5)
by metis
qed
qed
qed
qed
qed
lemma SMP_D':
fixes M
defines "δ ≡ var_rename (max_var_set (fv⇩s⇩e⇩t (set M)))"
assumes M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
and s: "s ∈ SMP (set M)" "is_Fun s" "∄f. s = Fun f []"
and t: "t ∈ SMP (set M)" "is_Fun t" "∄f. t = Fun f []"
obtains σ s0 θ t0
where "wt⇩s⇩u⇩b⇩s⇩t σ" "wf⇩t⇩r⇩m⇩s (subst_range σ)" "s0 ∈ set M" "is_Fun s0" "s = s0 ⋅ σ" "Γ s = Γ s0"
and "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "t0 ∈ set M" "is_Fun t0" "t = t0 ⋅ δ ⋅ θ" "Γ t = Γ t0"
proof -
obtain σ s0 where
s0: "wt⇩s⇩u⇩b⇩s⇩t σ" "wf⇩t⇩r⇩m⇩s (subst_range σ)" "s0 ∈ set M" "s = s0 ⋅ σ" "is_Fun s0"
using s(3) SMP_D[OF s(1,2) M_SMP_repr] unfolding δ_def by metis
obtain θ t0 where t0:
"wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "t0 ∈ set M" "t = t0 ⋅ δ ⋅ θ" "is_Fun t0"
using t(3) SMP_D[OF t(1,2) M_SMP_repr] var_rename_wt'[of _ t]
wf_trms_subst_compose_Var_range(1)[OF _ var_rename_is_renaming(2)]
unfolding δ_def by metis
have "Γ s = Γ s0" "Γ t = Γ (t0 ⋅ δ)" "Γ (t0 ⋅ δ) = Γ t0"
using s0 t0 wt_subst_trm'' by (metis, metis, metis δ_def var_rename_wt(1))
thus ?thesis using s0 t0 that by simp
qed
lemma SMP_D'':
fixes t::"('fun, ('fun, 'atom) term × nat) term"
assumes t_SMP: "t ∈ SMP (set M)"
and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
shows "∃m ∈ set M. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = m ⋅ δ"
proof (cases "(∃x. t = Var x) ∨ (∃c. t = Fun c [])")
case True
have M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
and M_subterms_cl: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
and M_Ana_cl: "has_all_wt_instances_of Γ (⋃((set ∘ fst ∘ Ana) ` set M)) (set M)"
using finite_SMP_representationD[OF M_SMP_repr] by blast+
have M_Ana_wf: "wf⇩t⇩r⇩m⇩s (⋃ ((set ∘ fst ∘ Ana) ` set M))"
proof
fix k assume "k ∈ ⋃((set ∘ fst ∘ Ana) ` set M)"
then obtain m where m: "m ∈ set M" "k ∈ set (fst (Ana m))" by force
thus "wf⇩t⇩r⇩m k" using M_wf Ana_keys_wf'[of m "fst (Ana m)" _ k] surjective_pairing by blast
qed
show ?thesis using True
proof
assume "∃x. t = Var x"
then obtain x y where x: "t = Var x" and y: "y ∈ fv⇩s⇩e⇩t (set M)" "Γ (Var y) = Γ (Var x)"
using SMP_D_aux1[OF t_SMP M_subterms_cl M_var_inst_cl M_wf] by fastforce
then obtain m δ where m: "m ∈ set M" "m ⋅ δ = Var y" and δ: "wt⇩s⇩u⇩b⇩s⇩t δ"
using has_all_wt_instances_ofD'[OF wf_trms_subterms[OF M_wf] M_wf M_subterms_cl, of "Var y"]
vars_iff_subtermeq_set[of y "set M"]
by fastforce
obtain z where z: "m = Var z" using m(2) by (cases m) auto
define θ where "θ ≡ Var(z := Var x)::('fun, ('fun, 'atom) term × nat) subst"
have "Γ (Var z) = Γ (Var x)" using y(2) m(2) z wt_subst_trm''[OF δ, of m] by argo
hence "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" unfolding θ_def wt⇩s⇩u⇩b⇩s⇩t_def by force+
moreover have "t = m ⋅ θ" using x z unfolding θ_def by simp
ultimately show ?thesis using m(1) by blast
qed (use SMP_D[OF t_SMP _ M_SMP_repr] in blast)
qed (use SMP_D[OF t_SMP _ M_SMP_repr] in blast)
end
lemma tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t:
assumes "comp_tfr⇩s⇩e⇩t arity Ana Γ M"
shows "tfr⇩s⇩e⇩t (set M)"
proof -
let ?δ = "var_rename (max_var_set (fv⇩s⇩e⇩t (set M)))"
have M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
by (metis comp_tfr⇩s⇩e⇩t_def assms)
have M_finite: "finite (set M)"
using assms card_gt_0_iff unfolding comp_tfr⇩s⇩e⇩t_def by blast
show ?thesis
proof (unfold tfr⇩s⇩e⇩t_def; intro ballI impI)
fix s t assume "s ∈ SMP (set M) - Var`𝒱" "t ∈ SMP (set M) - Var`𝒱"
hence st: "s ∈ SMP (set M)" "is_Fun s" "t ∈ SMP (set M)" "is_Fun t" by auto
have "¬(∃δ. Unifier δ s t)" when st_type_neq: "Γ s ≠ Γ t"
proof (cases "∃f. s = Fun f [] ∨ t = Fun f []")
case False
then obtain σ s0 θ t0 where
s0: "s0 ∈ set M" "is_Fun s0" "s = s0 ⋅ σ" "Γ s = Γ s0"
and t0: "t0 ∈ set M" "is_Fun t0" "t = t0 ⋅ ?δ ⋅ θ" "Γ t = Γ t0"
using SMP_D'[OF M_SMP_repr st(1,2) _ st(3,4)] by metis
hence "¬(∃δ. Unifier δ s0 (t0 ⋅ ?δ))"
using assms mgu_None_is_subst_neq st_type_neq wt_subst_trm''[OF var_rename_wt(1)]
unfolding comp_tfr⇩s⇩e⇩t_def Let_def by metis
thus ?thesis
using vars_term_disjoint_imp_unifier[OF var_rename_fv_set_disjoint[OF M_finite]] s0(1) t0(1)
unfolding s0(3) t0(3) by (metis (no_types, hide_lams) subst_subst_compose)
qed (use st_type_neq st(2,4) in auto)
thus "Γ s = Γ t" when "∃δ. Unifier δ s t" by (metis that)
qed
qed
lemma tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t':
assumes "let N = SMP0 Ana Γ M in set M ⊆ set N ∧ comp_tfr⇩s⇩e⇩t arity Ana Γ N"
shows "tfr⇩s⇩e⇩t (set M)"
by (rule tfr_subset(2)[
OF tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t[OF conjunct2[OF assms[unfolded Let_def]]]
conjunct1[OF assms[unfolded Let_def]]])
lemma tfr⇩s⇩t⇩p_is_comp_tfr⇩s⇩t⇩p: "tfr⇩s⇩t⇩p a = comp_tfr⇩s⇩t⇩p Γ a"
proof (cases a)
case (Equality ac t t')
thus ?thesis
using mgu_always_unifies[of t _ t'] mgu_gives_MGU[of t t']
by auto
next
case (Inequality X F)
thus ?thesis
using tfr⇩s⇩t⇩p.simps(2)[of X F]
comp_tfr⇩s⇩t⇩p.simps(2)[of Γ X F]
Fun_range_case(2)[of "subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F)"]
unfolding is_Var_def
by auto
qed auto
lemma tfr⇩s⇩t_if_comp_tfr⇩s⇩t:
assumes "comp_tfr⇩s⇩t arity Ana Γ M S"
shows "tfr⇩s⇩t S"
unfolding tfr⇩s⇩t_def
proof
have comp_tfr⇩s⇩e⇩t_M: "comp_tfr⇩s⇩e⇩t arity Ana Γ M"
using assms unfolding comp_tfr⇩s⇩t_def by blast
have wf⇩t⇩r⇩m⇩s_M: "wf⇩t⇩r⇩m⇩s (set M)"
and wf⇩t⇩r⇩m⇩s_S: "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)"
and S_trms_instance_M: "has_all_wt_instances_of Γ (trms⇩s⇩t S) (set M)"
using assms wf⇩t⇩r⇩m_code trms_list⇩s⇩t_is_trms⇩s⇩t
unfolding comp_tfr⇩s⇩t_def comp_tfr⇩s⇩e⇩t_def finite_SMP_representation_def list_all_iff
by blast+
show "tfr⇩s⇩e⇩t (trms⇩s⇩t S)"
using tfr_subset(3)[OF tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t[OF comp_tfr⇩s⇩e⇩t_M] SMP_SMP_subset]
SMP_I'[OF wf⇩t⇩r⇩m⇩s_S wf⇩t⇩r⇩m⇩s_M S_trms_instance_M]
by blast
have "list_all (comp_tfr⇩s⇩t⇩p Γ) S" by (metis assms comp_tfr⇩s⇩t_def)
thus "list_all tfr⇩s⇩t⇩p S" by (induct S) (simp_all add: tfr⇩s⇩t⇩p_is_comp_tfr⇩s⇩t⇩p)
qed
lemma tfr⇩s⇩t_if_comp_tfr⇩s⇩t':
assumes "comp_tfr⇩s⇩t arity Ana Γ (SMP0 Ana Γ (trms_list⇩s⇩t S)) S"
shows "tfr⇩s⇩t S"
by (rule tfr⇩s⇩t_if_comp_tfr⇩s⇩t[OF assms])
subsubsection ‹Lemmata for Checking Ground SMP (GSMP) Disjointness›
context
begin
private lemma ground_SMP_disjointI_aux1:
fixes M::"('fun, ('fun, 'atom) term × nat) term set"
assumes f_def: "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and g_def: "g ≡ λM. {t ∈ M. fv t = {}}"
shows "f (SMP M) = g (SMP M)"
proof
have "t ∈ f (SMP M)" when t: "t ∈ SMP M" "fv t = {}" for t
proof -
define δ where "δ ≡ Var::('fun, ('fun, 'atom) term × nat) subst"
have "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" "t = t ⋅ δ"
using subst_apply_term_empty[of t] that(2) wt_subst_Var wf_trm_subst_range_Var
unfolding δ_def by auto
thus ?thesis using SMP.Substitution[OF t(1), of δ] t(2) unfolding f_def by fastforce
qed
thus "g (SMP M) ⊆ f (SMP M)" unfolding g_def by blast
qed (use f_def g_def in blast)
private lemma ground_SMP_disjointI_aux2:
fixes M::"('fun, ('fun, 'atom) term × nat) term list"
assumes f_def: "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and M_SMP_repr: "finite_SMP_representation arity Ana Γ M"
shows "f (set M) = f (SMP (set M))"
proof
have M_wf: "wf⇩t⇩r⇩m⇩s (set M)"
and M_var_inst_cl: "is_TComp_var_instance_closed Γ M"
and M_subterms_cl: "has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set M)) (set M)"
and M_Ana_cl: "has_all_wt_instances_of Γ (⋃((set ∘ fst ∘ Ana) ` set M)) (set M)"
using finite_SMP_representationD[OF M_SMP_repr] by blast+
show "f (SMP (set M)) ⊆ f (set M)"
proof
fix t assume "t ∈ f (SMP (set M))"
then obtain s δ where s: "t = s ⋅ δ" "s ∈ SMP (set M)" "fv (s ⋅ δ) = {}"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
unfolding f_def by blast
have t_wf: "wf⇩t⇩r⇩m t" using SMP_wf_trm[OF s(2) M_wf] s(1) wf_trm_subst[OF δ(2)] by blast
obtain m θ where m: "m ∈ set M" "s = m ⋅ θ" and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using SMP_D''[OF s(2) M_SMP_repr] by blast
have "t = m ⋅ (θ ∘⇩s δ)" "fv (m ⋅ (θ ∘⇩s δ)) = {}" using s(1,3) m(2) by simp_all
thus "t ∈ f (set M)"
using m(1) wt_subst_compose[OF θ(1) δ(1)] wf_trms_subst_compose[OF θ(2) δ(2)]
unfolding f_def by blast
qed
qed (auto simp add: f_def)
private lemma ground_SMP_disjointI_aux3:
fixes A B C::"('fun, ('fun, 'atom) term × nat) term set"
defines "P ≡ λt s. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ Unifier δ t s"
assumes f_def: "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and Q_def: "Q ≡ λt. intruder_synth' public arity {} t"
and R_def: "R ≡ λt. ∃u ∈ C. is_wt_instance_of_cond Γ t u"
and AB: "wf⇩t⇩r⇩m⇩s A" "wf⇩t⇩r⇩m⇩s B" "fv⇩s⇩e⇩t A ∩ fv⇩s⇩e⇩t B = {}"
and C: "wf⇩t⇩r⇩m⇩s C"
and ABC: "∀t ∈ A. ∀s ∈ B. P t s ⟶ (Q t ∧ Q s) ∨ (R t ∧ R s)"
shows "f A ∩ f B ⊆ f C ∪ {m. {} ⊢⇩c m}"
proof
fix t assume "t ∈ f A ∩ f B"
then obtain ta tb δa δb where
ta: "t = ta ⋅ δa" "ta ∈ A" "wt⇩s⇩u⇩b⇩s⇩t δa" "wf⇩t⇩r⇩m⇩s (subst_range δa)" "fv (ta ⋅ δa) = {}"
and tb: "t = tb ⋅ δb" "tb ∈ B" "wt⇩s⇩u⇩b⇩s⇩t δb" "wf⇩t⇩r⇩m⇩s (subst_range δb)" "fv (tb ⋅ δb) = {}"
unfolding f_def by blast
have ta_tb_wf: "wf⇩t⇩r⇩m ta" "wf⇩t⇩r⇩m tb" "fv ta ∩ fv tb = {}" "Γ ta = Γ tb"
using ta(1,2) tb(1,2) AB fv_subset_subterms
wt_subst_trm''[OF ta(3), of ta] wt_subst_trm''[OF tb(3), of tb]
by (fast, fast, blast, simp)
obtain θ where θ: "Unifier θ ta tb" "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using vars_term_disjoint_imp_unifier[OF ta_tb_wf(3), of δa δb]
ta(1) tb(1) wt_Unifier_if_Unifier[OF ta_tb_wf(1,2,4)]
by blast
hence "(Q ta ∧ Q tb) ∨ (R ta ∧ R tb)" using ABC ta(2) tb(2) unfolding P_def by blast+
thus "t ∈ f C ∪ {m. {} ⊢⇩c m}"
proof
show "Q ta ∧ Q tb ⟹ ?thesis"
using ta(1) pgwt_ground[of ta] pgwt_is_empty_synth[of ta] subst_ground_ident[of ta δa]
unfolding Q_def f_def intruder_synth_code[symmetric] by simp
next
assume "R ta ∧ R tb"
then obtain ua σa where ua: "ta = ua ⋅ σa" "ua ∈ C" "wt⇩s⇩u⇩b⇩s⇩t σa" "wf⇩t⇩r⇩m⇩s (subst_range σa)"
using θ ABC ta_tb_wf(1,2) ta(2) tb(2) C is_wt_instance_of_condD'
unfolding P_def R_def by metis
have "t = ua ⋅ (σa ∘⇩s δa)" "fv t = {}"
using ua(1) ta(1,5) tb(1,5) by auto
thus ?thesis
using ua(2) wt_subst_compose[OF ua(3) ta(3)] wf_trms_subst_compose[OF ua(4) ta(4)]
unfolding f_def by blast
qed
qed
lemma ground_SMP_disjointI:
fixes A B::"('fun, ('fun, 'atom) term × nat) term list" and C
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and "g ≡ λM. {t ∈ M. fv t = {}}"
and "Q ≡ λt. intruder_synth' public arity {} t"
and "R ≡ λt. ∃u ∈ C. is_wt_instance_of_cond Γ t u"
assumes AB_fv_disj: "fv⇩s⇩e⇩t (set A) ∩ fv⇩s⇩e⇩t (set B) = {}"
and A_SMP_repr: "finite_SMP_representation arity Ana Γ A"
and B_SMP_repr: "finite_SMP_representation arity Ana Γ B"
and C_wf: "wf⇩t⇩r⇩m⇩s C"
and ABC: "∀t ∈ set A. ∀s ∈ set B. Γ t = Γ s ∧ mgu t s ≠ None ⟶ (Q t ∧ Q s) ∨ (R t ∧ R s)"
shows "g (SMP (set A)) ∩ g (SMP (set B)) ⊆ f C ∪ {m. {} ⊢⇩c m}"
proof -
have AB_wf: "wf⇩t⇩r⇩m⇩s (set A)" "wf⇩t⇩r⇩m⇩s (set B)"
using A_SMP_repr B_SMP_repr
unfolding finite_SMP_representation_def wf⇩t⇩r⇩m_code list_all_iff
by blast+
let ?P = "λt s. ∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ Unifier δ t s"
have ABC': "∀t ∈ set A. ∀s ∈ set B. ?P t s ⟶ (Q t ∧ Q s) ∨ (R t ∧ R s)"
by (metis (no_types) ABC mgu_None_is_subst_neq wt_subst_trm'')
show ?thesis
using ground_SMP_disjointI_aux1[OF f_def g_def, of "set A"]
ground_SMP_disjointI_aux1[OF f_def g_def, of "set B"]
ground_SMP_disjointI_aux2[OF f_def A_SMP_repr]
ground_SMP_disjointI_aux2[OF f_def B_SMP_repr]
ground_SMP_disjointI_aux3[OF f_def Q_def R_def AB_wf AB_fv_disj C_wf ABC']
by argo
qed
end
end
end
Theory Typing_Result
section ‹The Typing Result›
text ‹\label{sec:Typing-Result}›
theory Typing_Result
imports Typed_Model
begin
subsection ‹The Typing Result for the Composition-Only Intruder›
context typed_model
begin
subsubsection ‹Well-typedness and Type-Flaw Resistance Preservation›
context
begin
private lemma LI_preserves_tfr_stp_all_single:
assumes "(S,θ) ↝ (S',θ')" "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ"
and "list_all tfr⇩s⇩t⇩p S" "tfr⇩s⇩e⇩t (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)"
shows "list_all tfr⇩s⇩t⇩p S'"
using assms
proof (induction rule: LI_rel.induct)
case (Compose S X f S' θ)
hence "list_all tfr⇩s⇩t⇩p S" "list_all tfr⇩s⇩t⇩p S'" by simp_all
moreover have "list_all tfr⇩s⇩t⇩p (map Send X)" by (induct X) auto
ultimately show ?case by simp
next
case (Unify S f Y δ X S' θ)
hence "list_all tfr⇩s⇩t⇩p (S@S')" by simp
have "fv⇩s⇩t (S@Send (Fun f X)#S') ∩ bvars⇩s⇩t (S@S') = {}"
using Unify.prems(1) by (auto simp add: wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
moreover have "fv (Fun f X) ⊆ fv⇩s⇩t (S@Send (Fun f X)#S')" by auto
moreover have "fv (Fun f Y) ⊆ fv⇩s⇩t (S@Send (Fun f X)#S')"
using Unify.hyps(2) fv_subset_if_in_strand_ik'[of "Fun f Y" S] by force
ultimately have bvars_disj:
"bvars⇩s⇩t (S@S') ∩ fv (Fun f X) = {}" "bvars⇩s⇩t (S@S') ∩ fv (Fun f Y) = {}"
by blast+
have "wf⇩t⇩r⇩m (Fun f X)" using Unify.prems(5) by simp
moreover have "wf⇩t⇩r⇩m (Fun f Y)"
proof -
obtain x where "x ∈ set S" "Fun f Y ∈ subterms⇩s⇩e⇩t (trms⇩s⇩t⇩p x)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p x)"
using Unify.hyps(2) Unify.prems(5) by force+
thus ?thesis using wf_trm_subterm by auto
qed
moreover have
"Fun f X ∈ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))" "Fun f Y ∈ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))"
using SMP_append[of S "Send (Fun f X)#S'"] SMP_Cons[of "Send (Fun f X)" S']
SMP_ikI[OF Unify.hyps(2)]
by auto
hence "Γ (Fun f X) = Γ (Fun f Y)"
using Unify.prems(4) mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]
unfolding tfr⇩s⇩e⇩t_def by blast
ultimately have "wt⇩s⇩u⇩b⇩s⇩t δ" using mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric]] by metis
moreover have "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using mgu_wf_trm[OF Unify.hyps(3)[symmetric] ‹wf⇩t⇩r⇩m (Fun f X)› ‹wf⇩t⇩r⇩m (Fun f Y)›]
by (metis wf_trm_subst_range_iff)
moreover have "bvars⇩s⇩t (S@S') ∩ range_vars δ = {}"
using mgu_vars_bounded[OF Unify.hyps(3)[symmetric]] bvars_disj by fast
ultimately show ?case using tfr_stp_all_wt_subst_apply[OF ‹list_all tfr⇩s⇩t⇩p (S@S')›] by metis
next
case (Equality S δ t t' a S' θ)
have "list_all tfr⇩s⇩t⇩p (S@S')" "Γ t = Γ t'"
using tfr_stp_all_same_type[of S a t t' S']
tfr_stp_all_split(5)[of S _ S']
MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
Equality.prems(3)
by blast+
moreover have "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m t'" using Equality.prems(5) by auto
ultimately have "wt⇩s⇩u⇩b⇩s⇩t δ"
using mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric]]
by metis
moreover have "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using mgu_wf_trm[OF Equality.hyps(2)[symmetric] ‹wf⇩t⇩r⇩m t› ‹wf⇩t⇩r⇩m t'›]
by (metis wf_trm_subst_range_iff)
moreover have "fv⇩s⇩t (S@Equality a t t'#S') ∩ bvars⇩s⇩t (S@Equality a t t'#S') = {}"
using Equality.prems(1) by (auto simp add: wf⇩c⇩o⇩n⇩s⇩t⇩r_def)
hence "bvars⇩s⇩t (S@S') ∩ fv t = {}" "bvars⇩s⇩t (S@S') ∩ fv t' = {}" by auto
hence "bvars⇩s⇩t (S@S') ∩ range_vars δ = {}"
using mgu_vars_bounded[OF Equality.hyps(2)[symmetric]] by fast
ultimately show ?case using tfr_stp_all_wt_subst_apply[OF ‹list_all tfr⇩s⇩t⇩p (S@S')›] by metis
qed
private lemma LI_in_SMP_subset_single:
assumes "(S,θ) ↝ (S',θ')" "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ"
"tfr⇩s⇩e⇩t (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)" "list_all tfr⇩s⇩t⇩p S"
and "trms⇩s⇩t S ⊆ SMP M"
shows "trms⇩s⇩t S' ⊆ SMP M"
using assms
proof (induction rule: LI_rel.induct)
case (Compose S X f S' θ)
hence "SMP (trms⇩s⇩t [Send (Fun f X)]) ⊆ SMP M"
proof -
have "SMP (trms⇩s⇩t [Send (Fun f X)]) ⊆ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))"
using trms⇩s⇩t_append SMP_mono by auto
thus ?thesis
using SMP_union[of "trms⇩s⇩t (S@Send (Fun f X)#S')" M]
SMP_subset_union_eq[OF Compose.prems(6)]
by auto
qed
thus ?case using Compose.prems(6) by auto
next
case (Unify S f Y δ X S' θ)
have "Fun f X ∈ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))" by auto
moreover have "MGU δ (Fun f X) (Fun f Y)"
by (metis mgu_gives_MGU[OF Unify.hyps(3)[symmetric]])
moreover have
"⋀x. x ∈ set S ⟹ wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p x)" "wf⇩t⇩r⇩m (Fun f X)"
using Unify.prems(4) by force+
moreover have "Fun f Y ∈ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))"
by (meson SMP_ikI Unify.hyps(2) contra_subsetD ik_append_subset(1))
ultimately have "wf⇩t⇩r⇩m (Fun f Y)" "Γ (Fun f X) = Γ (Fun f Y)"
using ik⇩s⇩t_subterm_exD[OF ‹Fun f Y ∈ ik⇩s⇩t S›] ‹tfr⇩s⇩e⇩t (trms⇩s⇩t (S@Send (Fun f X)#S'))›
unfolding tfr⇩s⇩e⇩t_def by (metis (full_types) SMP_wf_trm Unify.prems(4), blast)
hence "wt⇩s⇩u⇩b⇩s⇩t δ" by (metis mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric] ‹wf⇩t⇩r⇩m (Fun f X)›])
moreover have "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using mgu_wf_trm[OF Unify.hyps(3)[symmetric] ‹wf⇩t⇩r⇩m (Fun f X)› ‹wf⇩t⇩r⇩m (Fun f Y)›] by simp
ultimately have "trms⇩s⇩t ((S@Send (Fun f X)#S') ⋅⇩s⇩t δ) ⊆ SMP M"
using SMP.Substitution Unify.prems(6) wt_subst_SMP_subset by metis
thus ?case by auto
next
case (Equality S δ t t' a S' θ)
hence "Γ t = Γ t'"
using tfr_stp_all_same_type MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
by metis
moreover have "t ∈ SMP (trms⇩s⇩t (S@Equality a t t'#S'))" "t' ∈ SMP (trms⇩s⇩t (S@Equality a t t'#S'))"
using Equality.prems(1) by auto
moreover have "MGU δ t t'" using mgu_gives_MGU[OF Equality.hyps(2)[symmetric]] by metis
moreover have "⋀x. x ∈ set S ⟹ wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p x)" "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m t'"
using Equality.prems(4) by force+
ultimately have "wt⇩s⇩u⇩b⇩s⇩t δ" by (metis mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric] ‹wf⇩t⇩r⇩m t›])
moreover have "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using mgu_wf_trm[OF Equality.hyps(2)[symmetric] ‹wf⇩t⇩r⇩m t› ‹wf⇩t⇩r⇩m t'›] by simp
ultimately have "trms⇩s⇩t ((S@Equality a t t'#S') ⋅⇩s⇩t δ) ⊆ SMP M"
using SMP.Substitution Equality.prems wt_subst_SMP_subset by metis
thus ?case by auto
qed
private lemma LI_preserves_tfr_single:
assumes "(S,θ) ↝ (S',θ')" "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
"tfr⇩s⇩e⇩t (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)"
"list_all tfr⇩s⇩t⇩p S"
shows "tfr⇩s⇩e⇩t (trms⇩s⇩t S') ∧ wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S')"
using assms
proof (induction rule: LI_rel.induct)
case (Compose S X f S' θ)
let ?SMPmap = "SMP (trms⇩s⇩t (S@map Send X@S')) - (Var`𝒱)"
have "?SMPmap ⊆ SMP (trms⇩s⇩t (S@Send (Fun f X)#S')) - (Var`𝒱)"
using SMP_fun_map_snd_subset[of X f]
SMP_append[of "map Send X" S'] SMP_Cons[of "Send (Fun f X)" S']
SMP_append[of S "Send (Fun f X)#S'"] SMP_append[of S "map Send X@S'"]
by auto
hence "∀s ∈ ?SMPmap. ∀t ∈ ?SMPmap. (∃δ. Unifier δ s t) ⟶ Γ s = Γ t"
using Compose unfolding tfr⇩s⇩e⇩t_def by (meson subsetCE)
thus ?case
using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Compose[OF Compose.hyps]], of S']
Compose.prems(5)
unfolding tfr⇩s⇩e⇩t_def by blast
next
case (Unify S f Y δ X S' θ)
let ?SMPδ = "SMP (trms⇩s⇩t (S@S' ⋅⇩s⇩t δ)) - (Var`𝒱)"
have "SMP (trms⇩s⇩t (S@S' ⋅⇩s⇩t δ)) ⊆ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))"
proof
fix s assume "s ∈ SMP (trms⇩s⇩t (S@S' ⋅⇩s⇩t δ))" thus "s ∈ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))"
using LI_in_SMP_subset_single[
OF LI_rel.Unify[OF Unify.hyps] Unify.prems(1,2,4,5,6)
MP_subset_SMP(2)[of "S@Send (Fun f X)#S'"]]
by (metis SMP_union SMP_subset_union_eq Un_iff)
qed
hence "∀s ∈ ?SMPδ. ∀t ∈ ?SMPδ. (∃δ. Unifier δ s t) ⟶ Γ s = Γ t"
using Unify.prems(4) unfolding tfr⇩s⇩e⇩t_def by (meson Diff_iff subsetCE)
thus ?case
using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Unify[OF Unify.hyps]], of S']
Unify.prems(5)
unfolding tfr⇩s⇩e⇩t_def by blast
next
case (Equality S δ t t' a S' θ)
let ?SMPδ = "SMP (trms⇩s⇩t (S@S' ⋅⇩s⇩t δ)) - (Var`𝒱)"
have "SMP (trms⇩s⇩t (S@S' ⋅⇩s⇩t δ)) ⊆ SMP (trms⇩s⇩t (S@Equality a t t'#S'))"
proof
fix s assume "s ∈ SMP (trms⇩s⇩t (S@S' ⋅⇩s⇩t δ))" thus "s ∈ SMP (trms⇩s⇩t (S@Equality a t t'#S'))"
using LI_in_SMP_subset_single[
OF LI_rel.Equality[OF Equality.hyps] Equality.prems(1,2,4,5,6)
MP_subset_SMP(2)[of "S@Equality a t t'#S'"]]
by (metis SMP_union SMP_subset_union_eq Un_iff)
qed
hence "∀s ∈ ?SMPδ. ∀t ∈ ?SMPδ. (∃δ. Unifier δ s t) ⟶ Γ s = Γ t"
using Equality.prems unfolding tfr⇩s⇩e⇩t_def by (meson Diff_iff subsetCE)
thus ?case
using LI_preserves_trm_wf[OF r_into_rtrancl[OF LI_rel.Equality[OF Equality.hyps]], of _ S']
Equality.prems
unfolding tfr⇩s⇩e⇩t_def by blast
qed
private lemma LI_preserves_welltypedness_single:
assumes "(S,θ) ↝ (S',θ')" "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and "tfr⇩s⇩e⇩t (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)" "list_all tfr⇩s⇩t⇩p S"
shows "wt⇩s⇩u⇩b⇩s⇩t θ' ∧ wf⇩t⇩r⇩m⇩s (subst_range θ')"
using assms
proof (induction rule: LI_rel.induct)
case (Unify S f Y δ X S' θ)
have "wf⇩t⇩r⇩m (Fun f X)" using Unify.prems(5) unfolding tfr⇩s⇩e⇩t_def by simp
moreover have "wf⇩t⇩r⇩m (Fun f Y)"
proof -
obtain x where "x ∈ set S" "Fun f Y ∈ subterms⇩s⇩e⇩t (trms⇩s⇩t⇩p x)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t⇩p x)"
using Unify.hyps(2) Unify.prems(5) unfolding tfr⇩s⇩e⇩t_def by force
thus ?thesis using wf_trm_subterm by auto
qed
moreover have
"Fun f X ∈ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))" "Fun f Y ∈ SMP (trms⇩s⇩t (S@Send (Fun f X)#S'))"
using SMP_append[of S "Send (Fun f X)#S'"] SMP_Cons[of "Send (Fun f X)" S']
SMP_ikI[OF Unify.hyps(2)]
by auto
hence "Γ (Fun f X) = Γ (Fun f Y)"
using Unify.prems(4) mgu_gives_MGU[OF Unify.hyps(3)[symmetric]]
unfolding tfr⇩s⇩e⇩t_def by blast
ultimately have "wt⇩s⇩u⇩b⇩s⇩t δ" using mgu_wt_if_same_type[OF Unify.hyps(3)[symmetric]] by metis
have "wf⇩t⇩r⇩m⇩s (subst_range δ)"
by (meson mgu_wf_trm[OF Unify.hyps(3)[symmetric] ‹wf⇩t⇩r⇩m (Fun f X)› ‹wf⇩t⇩r⇩m (Fun f Y)›]
wf_trm_subst_range_iff)
hence "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s δ))"
using wf_trm_subst_range_iff wf_trm_subst ‹wf⇩t⇩r⇩m⇩s (subst_range θ)›
unfolding subst_compose_def
by (metis (no_types, lifting))
thus ?case by (metis wt_subst_compose[OF ‹wt⇩s⇩u⇩b⇩s⇩t θ› ‹wt⇩s⇩u⇩b⇩s⇩t δ›])
next
case (Equality S δ t t' a S' θ)
have "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m t'" using Equality.prems(5) by simp_all
moreover have "Γ t = Γ t'"
using ‹list_all tfr⇩s⇩t⇩p (S@Equality a t t'#S')›
MGU_is_Unifier[OF mgu_gives_MGU[OF Equality.hyps(2)[symmetric]]]
by auto
ultimately have "wt⇩s⇩u⇩b⇩s⇩t δ" using mgu_wt_if_same_type[OF Equality.hyps(2)[symmetric]] by metis
have "wf⇩t⇩r⇩m⇩s (subst_range δ)"
by (meson mgu_wf_trm[OF Equality.hyps(2)[symmetric] ‹wf⇩t⇩r⇩m t› ‹wf⇩t⇩r⇩m t'›] wf_trm_subst_range_iff)
hence "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s δ))"
using wf_trm_subst_range_iff wf_trm_subst ‹wf⇩t⇩r⇩m⇩s (subst_range θ)›
unfolding subst_compose_def
by (metis (no_types, lifting))
thus ?case by (metis wt_subst_compose[OF ‹wt⇩s⇩u⇩b⇩s⇩t θ› ‹wt⇩s⇩u⇩b⇩s⇩t δ›])
qed metis
lemma LI_preserves_welltypedness:
assumes "(S,θ) ↝⇧* (S',θ')" "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and "tfr⇩s⇩e⇩t (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)" "list_all tfr⇩s⇩t⇩p S"
shows "wt⇩s⇩u⇩b⇩s⇩t θ'" (is "?A θ'")
and "wf⇩t⇩r⇩m⇩s (subst_range θ')" (is "?B θ'")
proof -
have "?A θ' ∧ ?B θ'" using assms
proof (induction S θ rule: converse_rtrancl_induct2)
case (step S1 θ1 S2 θ2)
hence "?A θ2 ∧ ?B θ2" using LI_preserves_welltypedness_single by presburger
moreover have "wf⇩c⇩o⇩n⇩s⇩t⇩r S2 θ2"
by (fact LI_preserves_wellformedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems(1)])
moreover have "tfr⇩s⇩e⇩t (trms⇩s⇩t S2)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S2)"
using LI_preserves_tfr_single[OF step.hyps(1)] step.prems by presburger+
moreover have "list_all tfr⇩s⇩t⇩p S2"
using LI_preserves_tfr_stp_all_single[OF step.hyps(1)] step.prems by fastforce
ultimately show ?case using step.IH by presburger
qed simp
thus "?A θ'" "?B θ'" by simp_all
qed
lemma LI_preserves_tfr:
assumes "(S,θ) ↝⇧* (S',θ')" "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and "tfr⇩s⇩e⇩t (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)" "list_all tfr⇩s⇩t⇩p S"
shows "tfr⇩s⇩e⇩t (trms⇩s⇩t S')" (is "?A S'")
and "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S')" (is "?B S'")
and "list_all tfr⇩s⇩t⇩p S'" (is "?C S'")
proof -
have "?A S' ∧ ?B S' ∧ ?C S'" using assms
proof (induction S θ rule: converse_rtrancl_induct2)
case (step S1 θ1 S2 θ2)
have "wf⇩c⇩o⇩n⇩s⇩t⇩r S2 θ2" "tfr⇩s⇩e⇩t (trms⇩s⇩t S2)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S2)" "list_all tfr⇩s⇩t⇩p S2"
using LI_preserves_wellformedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems(1)]
LI_preserves_tfr_single[OF step.hyps(1) step.prems(1,2)]
LI_preserves_tfr_stp_all_single[OF step.hyps(1) step.prems(1,2)]
step.prems(3,4,5,6)
by metis+
moreover have "wt⇩s⇩u⇩b⇩s⇩t θ2" "wf⇩t⇩r⇩m⇩s (subst_range θ2)"
using LI_preserves_welltypedness[OF r_into_rtrancl[OF step.hyps(1)] step.prems]
by simp_all
ultimately show ?case using step.IH by presburger
qed blast
thus "?A S'" "?B S'" "?C S'" by simp_all
qed
end
subsubsection ‹Simple Constraints are Well-typed Satisfiable›
text ‹Proving the existence of a well-typed interpretation›
context
begin
lemma wt_interpretation_exists:
obtains ℐ::"('fun,'var) subst"
where "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "wt⇩s⇩u⇩b⇩s⇩t ℐ" "subst_range ℐ ⊆ public_ground_wf_terms"
proof
define ℐ where "ℐ = (λx. (SOME t. Γ (Var x) = Γ t ∧ public_ground_wf_term t))"
{ fix x t assume "ℐ x = t"
hence "Γ (Var x) = Γ t ∧ public_ground_wf_term t"
using someI_ex[of "λt. Γ (Var x) = Γ t ∧ public_ground_wf_term t",
OF type_pgwt_inhabited[of "Var x"]]
unfolding ℐ_def wf⇩t⇩r⇩m_def by simp
} hence props: "ℐ v = t ⟹ Γ (Var v) = Γ t ∧ public_ground_wf_term t" for v t by metis
have "ℐ v ≠ Var v" for v using props pgwt_ground by (simp add: empty_fv_not_var)
hence "subst_domain ℐ = UNIV" by auto
moreover have "ground (subst_range ℐ)" by (simp add: props pgwt_ground)
ultimately show "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" by metis
show "wt⇩s⇩u⇩b⇩s⇩t ℐ" unfolding wt⇩s⇩u⇩b⇩s⇩t_def using props by simp
show "subst_range ℐ ⊆ public_ground_wf_terms" by (auto simp add: props)
qed
lemma wt_grounding_subst_exists:
"∃θ. wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range θ) ∧ fv (t ⋅ θ) = {}"
proof -
obtain θ where θ: "interpretation⇩s⇩u⇩b⇩s⇩t θ" "wt⇩s⇩u⇩b⇩s⇩t θ" "subst_range θ ⊆ public_ground_wf_terms"
using wt_interpretation_exists by blast
show ?thesis using pgwt_wellformed interpretation_grounds[OF θ(1)] θ(2,3) by blast
qed
private fun fresh_pgwt::"'fun set ⇒ ('fun,'atom) term_type ⇒ ('fun,'var) term" where
"fresh_pgwt S (TAtom a) =
Fun (SOME c. c ∉ S ∧ Γ (Fun c []) = TAtom a ∧ public c) []"
| "fresh_pgwt S (TComp f T) = Fun f (map (fresh_pgwt S) T)"
private lemma fresh_pgwt_same_type:
assumes "finite S" "wf⇩t⇩r⇩m t"
shows "Γ (fresh_pgwt S (Γ t)) = Γ t"
proof -
let ?P = "λτ::('fun,'atom) term_type. wf⇩t⇩r⇩m τ ∧ (∀f T. TComp f T ⊑ τ ⟶ 0 < arity f)"
{ fix τ assume "?P τ" hence "Γ (fresh_pgwt S τ) = τ"
proof (induction τ)
case (Var a)
let ?P = "λc. c ∉ S ∧ Γ (Fun c []) = Var a ∧ public c"
let ?Q = "λc. Γ (Fun c []) = Var a ∧ public c"
have " {c. ?Q c} - S = {c. ?P c}" by auto
hence "infinite {c. ?P c}"
using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
by metis
hence "∃c. ?P c" using not_finite_existsD by blast
thus ?case using someI_ex[of ?P] by auto
next
case (Fun f T)
have f: "0 < arity f" using Fun.prems fun_type_inv by auto
have "⋀t. t ∈ set T ⟹ ?P t"
using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
by metis
hence "⋀t. t ∈ set T ⟹ Γ (fresh_pgwt S t) = t" using Fun.prems Fun.IH by auto
hence "map Γ (map (fresh_pgwt S) T) = T" by (induct T) auto
thus ?case using fun_type[OF f] by simp
qed
} thus ?thesis using assms(1) Γ_wf'[OF assms(2)] Γ_wf(1) by auto
qed
private lemma fresh_pgwt_empty_synth:
assumes "finite S" "wf⇩t⇩r⇩m t"
shows "{} ⊢⇩c fresh_pgwt S (Γ t)"
proof -
let ?P = "λτ::('fun,'atom) term_type. wf⇩t⇩r⇩m τ ∧ (∀f T. TComp f T ⊑ τ ⟶ 0 < arity f)"
{ fix τ assume "?P τ" hence "{} ⊢⇩c fresh_pgwt S τ"
proof (induction τ)
case (Var a)
let ?P = "λc. c ∉ S ∧ Γ (Fun c []) = Var a ∧ public c"
let ?Q = "λc. Γ (Fun c []) = Var a ∧ public c"
have " {c. ?Q c} - S = {c. ?P c}" by auto
hence "infinite {c. ?P c}"
using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
by metis
hence "∃c. ?P c" using not_finite_existsD by blast
thus ?case
using someI_ex[of ?P] intruder_synth.ComposeC[of "[]" _ "{}"] const_type_inv
by auto
next
case (Fun f T)
have f: "0 < arity f" "length T = arity f" "public f"
using Fun.prems fun_type_inv unfolding wf⇩t⇩r⇩m_def by auto
have "⋀t. t ∈ set T ⟹ ?P t"
using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
by metis
hence "⋀t. t ∈ set T ⟹ {} ⊢⇩c fresh_pgwt S t" using Fun.prems Fun.IH by auto
moreover have "length (map (fresh_pgwt S) T) = arity f" using f(2) by auto
ultimately show ?case using intruder_synth.ComposeC[of "map (fresh_pgwt S) T" f] f by auto
qed
} thus ?thesis using assms(1) Γ_wf'[OF assms(2)] Γ_wf(1) by auto
qed
private lemma fresh_pgwt_has_fresh_const:
assumes "finite S" "wf⇩t⇩r⇩m t"
obtains c where "Fun c [] ⊑ fresh_pgwt S (Γ t)" "c ∉ S"
proof -
let ?P = "λτ::('fun,'atom) term_type. wf⇩t⇩r⇩m τ ∧ (∀f T. TComp f T ⊑ τ ⟶ 0 < arity f)"
{ fix τ assume "?P τ" hence "∃c. Fun c [] ⊑ fresh_pgwt S τ ∧ c ∉ S"
proof (induction τ)
case (Var a)
let ?P = "λc. c ∉ S ∧ Γ (Fun c []) = Var a ∧ public c"
let ?Q = "λc. Γ (Fun c []) = Var a ∧ public c"
have " {c. ?Q c} - S = {c. ?P c}" by auto
hence "infinite {c. ?P c}"
using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
by metis
hence "∃c. ?P c" using not_finite_existsD by blast
thus ?case using someI_ex[of ?P] by auto
next
case (Fun f T)
have f: "0 < arity f" "length T = arity f" "public f" "T ≠ []"
using Fun.prems fun_type_inv unfolding wf⇩t⇩r⇩m_def by auto
obtain t' where t': "t' ∈ set T" by (meson all_not_in_conv f(4) set_empty)
have "⋀t. t ∈ set T ⟹ ?P t"
using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
by metis
hence "⋀t. t ∈ set T ⟹ ∃c. Fun c [] ⊑ fresh_pgwt S t ∧ c ∉ S"
using Fun.prems Fun.IH by auto
then obtain c where c: "Fun c [] ⊑ fresh_pgwt S t'" "c ∉ S" using t' by metis
thus ?case using t' by auto
qed
} thus ?thesis using that assms Γ_wf'[OF assms(2)] Γ_wf(1) by blast
qed
private lemma fresh_pgwt_subterm_fresh:
assumes "finite S" "wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m s" "funs_term s ⊆ S"
shows "s ∉ subterms (fresh_pgwt S (Γ t))"
proof -
let ?P = "λτ::('fun,'atom) term_type. wf⇩t⇩r⇩m τ ∧ (∀f T. TComp f T ⊑ τ ⟶ 0 < arity f)"
{ fix τ assume "?P τ" hence "s ∉ subterms (fresh_pgwt S τ)"
proof (induction τ)
case (Var a)
let ?P = "λc. c ∉ S ∧ Γ (Fun c []) = Var a ∧ public c"
let ?Q = "λc. Γ (Fun c []) = Var a ∧ public c"
have " {c. ?Q c} - S = {c. ?P c}" by auto
hence "infinite {c. ?P c}"
using Diff_infinite_finite[OF assms(1) infinite_typed_consts[of a]]
by metis
hence "∃c. ?P c" using not_finite_existsD by blast
thus ?case using someI_ex[of ?P] assms(4) by auto
next
case (Fun f T)
have f: "0 < arity f" "length T = arity f" "public f"
using Fun.prems fun_type_inv unfolding wf⇩t⇩r⇩m_def by auto
have "⋀t. t ∈ set T ⟹ ?P t"
using Fun.prems wf_trm_subtermeq term.le_less_trans Fun_param_is_subterm
by metis
hence "⋀t. t ∈ set T ⟹ s ∉ subterms (fresh_pgwt S t)" using Fun.prems Fun.IH by auto
moreover have "s ≠ fresh_pgwt S (Fun f T)"
proof -
obtain c where c: "Fun c [] ⊑ fresh_pgwt S (Fun f T)" "c ∉ S"
using fresh_pgwt_has_fresh_const[OF assms(1)] type_wfttype_inhabited Fun.prems
by metis
hence "¬Fun c [] ⊑ s" using assms(4) subtermeq_imp_funs_term_subset by force
thus ?thesis using c(1) by auto
qed
ultimately show ?case by auto
qed
} thus ?thesis using assms(1) Γ_wf'[OF assms(2)] Γ_wf(1) by auto
qed
private lemma wt_fresh_pgwt_term_exists:
assumes "finite T" "wf⇩t⇩r⇩m s" "wf⇩t⇩r⇩m⇩s T"
obtains t where "Γ t = Γ s" "{} ⊢⇩c t" "∀s ∈ T. ∀u ∈ subterms s. u ∉ subterms t"
proof -
have finite_S: "finite (⋃(funs_term ` T))" using assms(1) by auto
have 1: "Γ (fresh_pgwt (⋃(funs_term ` T)) (Γ s)) = Γ s"
using fresh_pgwt_same_type[OF finite_S assms(2)] by auto
have 2: "{} ⊢⇩c fresh_pgwt (⋃(funs_term ` T)) (Γ s)"
using fresh_pgwt_empty_synth[OF finite_S assms(2)] by auto
have 3: "∀v ∈ T. ∀u ∈ subterms v. u ∉ subterms (fresh_pgwt (⋃(funs_term ` T)) (Γ s))"
using fresh_pgwt_subterm_fresh[OF finite_S assms(2)] assms(3)
wf_trm_subtermeq subtermeq_imp_funs_term_subset
by force
show ?thesis by (rule that[OF 1 2 3])
qed
lemma wt_bij_finite_subst_exists:
assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)" "wf⇩t⇩r⇩m⇩s T"
shows "∃σ::('fun,'var) subst.
subst_domain σ = S
∧ bij_betw σ (subst_domain σ) (subst_range σ)
∧ subterms⇩s⇩e⇩t (subst_range σ) ⊆ {t. {} ⊢⇩c t} - T
∧ (∀s ∈ subst_range σ. ∀u ∈ subst_range σ. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u)
∧ wt⇩s⇩u⇩b⇩s⇩t σ
∧ wf⇩t⇩r⇩m⇩s (subst_range σ)"
using assms
proof (induction rule: finite_induct)
case empty
have "subst_domain Var = {}"
"bij_betw Var (subst_domain Var) (subst_range Var)"
"subterms⇩s⇩e⇩t (subst_range Var) ⊆ {t. {} ⊢⇩c t} - T"
"∀s ∈ subst_range Var. ∀u ∈ subst_range Var. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u"
"wt⇩s⇩u⇩b⇩s⇩t Var"
"wf⇩t⇩r⇩m⇩s (subst_range Var)"
unfolding bij_betw_def
by auto
thus ?case by (force simp add: subst_domain_def)
next
case (insert x S)
then obtain σ where σ:
"subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
"subterms⇩s⇩e⇩t (subst_range σ) ⊆ {t. {} ⊢⇩c t} - T"
"∀s ∈ subst_range σ. ∀u ∈ subst_range σ. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u"
"wt⇩s⇩u⇩b⇩s⇩t σ" "wf⇩t⇩r⇩m⇩s (subst_range σ)"
by (auto simp del: subst_range.simps)
have *: "finite (T ∪ subst_range σ)"
using insert.prems(1) insert.hyps(1) σ(1) by simp
have **: "wf⇩t⇩r⇩m (Var x)" by simp
have ***: "wf⇩t⇩r⇩m⇩s (T ∪ subst_range σ)" using assms(3) σ(6) by blast
obtain t where t:
"Γ t = Γ (Var x)" "{} ⊢⇩c t"
"∀s ∈ T ∪ subst_range σ. ∀u ∈ subterms s. u ∉ subterms t"
using wt_fresh_pgwt_term_exists[OF * ** ***] by auto
obtain θ where θ: "θ ≡ λy. if x = y then t else σ y" by simp
have t_ground: "fv t = {}" using t(2) pgwt_ground[of t] pgwt_is_empty_synth[of t] by auto
hence x_dom: "x ∉ subst_domain σ" "x ∈ subst_domain θ" using insert.hyps(2) σ(1) θ by auto
moreover have "subst_range σ ⊆ subterms⇩s⇩e⇩t (subst_range σ)" by auto
hence ground_imgs: "ground (subst_range σ)"
using σ(3) pgwt_ground pgwt_is_empty_synth
by force
ultimately have x_img: "σ x ∉ subst_range σ"
using ground_subst_dom_iff_img
by (auto simp add: subst_domain_def)
have "ground (insert t (subst_range σ))"
using ground_imgs x_dom t_ground
by auto
have θ_dom: "subst_domain θ = insert x (subst_domain σ)"
using θ t_ground by (auto simp add: subst_domain_def)
have θ_img: "subst_range θ = insert t (subst_range σ)"
proof
show "subst_range θ ⊆ insert t (subst_range σ)"
proof
fix t' assume "t' ∈ subst_range θ"
then obtain y where "y ∈ subst_domain θ" "t' = θ y" by auto
thus "t' ∈ insert t (subst_range σ)" using θ by (auto simp add: subst_domain_def)
qed
show "insert t (subst_range σ) ⊆ subst_range θ"
proof
fix t' assume t': "t' ∈ insert t (subst_range σ)"
hence "fv t' = {}" using ground_imgs x_img t_ground by auto
hence "t' ≠ Var x" by auto
show "t' ∈ subst_range θ"
proof (cases "t' = t")
case False
hence "t' ∈ subst_range σ" using t' by auto
then obtain y where "σ y ∈ subst_range σ" "t' = σ y" by auto
hence "y ∈ subst_domain σ" "t' ≠ Var y"
using ground_subst_dom_iff_img[OF ground_imgs(1)]
by (auto simp add: subst_domain_def simp del: subst_range.simps)
hence "x ≠ y" using x_dom by auto
hence "θ y = σ y" unfolding θ by auto
thus ?thesis using ‹t' ≠ Var y› ‹t' = σ y› subst_imgI[of θ y] by auto
qed (metis subst_imgI θ ‹t' ≠ Var x›)
qed
qed
hence θ_ground_img: "ground (subst_range θ)"
using ground_imgs t_ground
by auto
have "subst_domain θ = insert x S" using θ_dom σ(1) by auto
moreover have "bij_betw θ (subst_domain θ) (subst_range θ)"
proof (intro bij_betwI')
fix y z assume *: "y ∈ subst_domain θ" "z ∈ subst_domain θ"
hence "fv (θ y) = {}" "fv (θ z) = {}" using θ_ground_img by auto
{ assume "θ y = θ z" hence "y = z"
proof (cases "θ y ∈ subst_range σ ∧ θ z ∈ subst_range σ")
case True
hence **: "y ∈ subst_domain σ" "z ∈ subst_domain σ"
using θ θ_dom True * t(3) by (metis Un_iff term.order_refl insertE)+
hence "y ≠ x" "z ≠ x" using x_dom by auto
hence "θ y = σ y" "θ z = σ z" using θ by auto
thus ?thesis using ‹θ y = θ z› σ(2) ** unfolding bij_betw_def inj_on_def by auto
qed (metis θ * ‹θ y = θ z› θ_dom ground_imgs(1) ground_subst_dom_iff_img insertE)
}
thus "(θ y = θ z) = (y = z)" by auto
next
fix y assume "y ∈ subst_domain θ" thus "θ y ∈ subst_range θ" by auto
next
fix t assume "t ∈ subst_range θ" thus "∃z ∈ subst_domain θ. t = θ z" by auto
qed
moreover have "subterms⇩s⇩e⇩t (subst_range θ) ⊆ {t. {} ⊢⇩c t} - T"
proof -
{ fix s assume "s ⊑ t"
hence "s ∈ {t. {} ⊢⇩c t} - T"
using t(2,3)
by (metis Diff_eq_empty_iff Diff_iff Un_upper1 term.order_refl
deduct_synth_subterm mem_Collect_eq)
} thus ?thesis using σ(3) θ θ_img by auto
qed
moreover have "wt⇩s⇩u⇩b⇩s⇩t θ" using θ t(1) σ(5) unfolding wt⇩s⇩u⇩b⇩s⇩t_def by auto
moreover have "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using θ σ(6) t(2) pgwt_is_empty_synth pgwt_wellformed
wf_trm_subst_range_iff[of σ] wf_trm_subst_range_iff[of θ]
by metis
moreover have "∀s∈subst_range θ. ∀u∈subst_range θ. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u"
using σ(4) θ_img t(3) by (auto simp del: subst_range.simps)
ultimately show ?case by blast
qed
private lemma wt_bij_finite_tatom_subst_exists_single:
assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)"
and "⋀x. x ∈ S ⟹ Γ (Var x) = TAtom a"
shows "∃σ::('fun,'var) subst. subst_domain σ = S
∧ bij_betw σ (subst_domain σ) (subst_range σ)
∧ subst_range σ ⊆ ((λc. Fun c []) ` {c. Γ (Fun c []) = TAtom a ∧
public c ∧ arity c = 0}) - T
∧ wt⇩s⇩u⇩b⇩s⇩t σ
∧ wf⇩t⇩r⇩m⇩s (subst_range σ)"
proof -
let ?U = "{c. Γ (Fun c []) = TAtom a ∧ public c ∧ arity c = 0}"
obtain σ where σ:
"subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
"subst_range σ ⊆ ((λc. Fun c []) ` ?U) - T"
using bij_finite_const_subst_exists'[OF assms(1,2) infinite_typed_consts'[of a]]
by auto
{ fix x assume "x ∉ subst_domain σ" hence "Γ (Var x) = Γ (σ x)" by auto }
moreover
{ fix x assume "x ∈ subst_domain σ"
hence "∃c ∈ ?U. σ x = Fun c [] ∧ arity c = 0" using σ by auto
hence "Γ (σ x) = TAtom a" "wf⇩t⇩r⇩m (σ x)" using assms(3) const_type wf_trmI[of "[]"] by auto
hence "Γ (Var x) = Γ (σ x)" "wf⇩t⇩r⇩m (σ x)" using assms(3) σ(1) by force+
}
ultimately have "wt⇩s⇩u⇩b⇩s⇩t σ" "wf⇩t⇩r⇩m⇩s (subst_range σ)"
using wf_trm_subst_range_iff[of σ]
unfolding wt⇩s⇩u⇩b⇩s⇩t_def
by force+
thus ?thesis using σ by auto
qed
lemma wt_bij_finite_tatom_subst_exists:
assumes "finite (S::'var set)" "finite (T::('fun,'var) terms)"
and "⋀x. x ∈ S ⟹ ∃a. Γ (Var x) = TAtom a"
shows "∃σ::('fun,'var) subst. subst_domain σ = S
∧ bij_betw σ (subst_domain σ) (subst_range σ)
∧ subst_range σ ⊆ ((λc. Fun c []) ` 𝒞⇩p⇩u⇩b) - T
∧ wt⇩s⇩u⇩b⇩s⇩t σ
∧ wf⇩t⇩r⇩m⇩s (subst_range σ)"
using assms
proof (induction rule: finite_induct)
case empty
have "subst_domain Var = {}"
"bij_betw Var (subst_domain Var) (subst_range Var)"
"subst_range Var ⊆ ((λc. Fun c []) ` 𝒞⇩p⇩u⇩b) - T"
"wt⇩s⇩u⇩b⇩s⇩t Var"
"wf⇩t⇩r⇩m⇩s (subst_range Var)"
unfolding bij_betw_def
by auto
thus ?case by (auto simp add: subst_domain_def)
next
case (insert x S)
then obtain a where a: "Γ (Var x) = TAtom a" by fastforce
from insert obtain σ where σ:
"subst_domain σ = S" "bij_betw σ (subst_domain σ) (subst_range σ)"
"subst_range σ ⊆ ((λc. Fun c []) ` 𝒞⇩p⇩u⇩b) - T" "wt⇩s⇩u⇩b⇩s⇩t σ"
"wf⇩t⇩r⇩m⇩s (subst_range σ)"
by auto
let ?S' = "{y ∈ S. Γ (Var y) = TAtom a}"
let ?T' = "T ∪ subst_range σ"
have *: "finite (insert x ?S')" using insert by simp
have **: "finite ?T'" using insert.prems(1) insert.hyps(1) σ(1) by simp
have ***: "⋀y. y ∈ insert x ?S' ⟹ Γ (Var y) = TAtom a" using a by auto
obtain δ where δ:
"subst_domain δ = insert x ?S'" "bij_betw δ (subst_domain δ) (subst_range δ)"
"subst_range δ ⊆ ((λc. Fun c []) ` 𝒞⇩p⇩u⇩b) - ?T'" "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using wt_bij_finite_tatom_subst_exists_single[OF * ** ***] const_type_inv[of _ "[]" a]
by blast
obtain θ where θ: "θ ≡ λy. if x = y then δ y else σ y" by simp
have x_dom: "x ∉ subst_domain σ" "x ∈ subst_domain δ" "x ∈ subst_domain θ"
using insert.hyps(2) σ(1) δ(1) θ by (auto simp add: subst_domain_def)
moreover have ground_imgs: "ground (subst_range σ)" "ground (subst_range δ)"
using pgwt_ground σ(3) δ(3) by auto
ultimately have x_img: "σ x ∉ subst_range σ" "δ x ∈ subst_range δ"
using ground_subst_dom_iff_img by (auto simp add: subst_domain_def)
have "ground (insert (δ x) (subst_range σ))" using ground_imgs x_dom by auto
have θ_dom: "subst_domain θ = insert x (subst_domain σ)"
using δ(1) θ by (auto simp add: subst_domain_def)
have θ_img: "subst_range θ = insert (δ x) (subst_range σ)"
proof
show "subst_range θ ⊆ insert (δ x) (subst_range σ)"
proof
fix t assume "t ∈ subst_range θ"
then obtain y where "y ∈ subst_domain θ" "t = θ y" by auto
thus "t ∈ insert (δ x) (subst_range σ)" using θ by (auto simp add: subst_domain_def)
qed
show "insert (δ x) (subst_range σ) ⊆ subst_range θ"
proof
fix t assume t: "t ∈ insert (δ x) (subst_range σ)"
hence "fv t = {}" using ground_imgs x_img(2) by auto
hence "t ≠ Var x" by auto
show "t ∈ subst_range θ"
proof (cases "t = δ x")
case True thus ?thesis using subst_imgI θ ‹t ≠ Var x› by metis
next
case False
hence "t ∈ subst_range σ" using t by auto
then obtain y where "σ y ∈ subst_range σ" "t = σ y" by auto
hence "y ∈ subst_domain σ" "t ≠ Var y"
using ground_subst_dom_iff_img[OF ground_imgs(1)]
by (auto simp add: subst_domain_def simp del: subst_range.simps)
hence "x ≠ y" using x_dom by auto
hence "θ y = σ y" unfolding θ by auto
thus ?thesis using ‹t ≠ Var y› ‹t = σ y› subst_imgI[of θ y] by auto
qed
qed
qed
hence θ_ground_img: "ground (subst_range θ)" using ground_imgs x_img by auto
have "subst_domain θ = insert x S" using θ_dom σ(1) by auto
moreover have "bij_betw θ (subst_domain θ) (subst_range θ)"
proof (intro bij_betwI')
fix y z assume *: "y ∈ subst_domain θ" "z ∈ subst_domain θ"
hence "fv (θ y) = {}" "fv (θ z) = {}" using θ_ground_img by auto
{ assume "θ y = θ z" hence "y = z"
proof (cases "θ y ∈ subst_range σ ∧ θ z ∈ subst_range σ")
case True
hence **: "y ∈ subst_domain σ" "z ∈ subst_domain σ"
using θ θ_dom x_img(2) δ(3) True
by (metis (no_types) *(1) DiffE Un_upper2 insertE subsetCE,
metis (no_types) *(2) DiffE Un_upper2 insertE subsetCE)
hence "y ≠ x" "z ≠ x" using x_dom by auto
hence "θ y = σ y" "θ z = σ z" using θ by auto
thus ?thesis using ‹θ y = θ z› σ(2) ** unfolding bij_betw_def inj_on_def by auto
qed (metis θ * ‹θ y = θ z› θ_dom ground_imgs(1) ground_subst_dom_iff_img insertE)
}
thus "(θ y = θ z) = (y = z)" by auto
next
fix y assume "y ∈ subst_domain θ" thus "θ y ∈ subst_range θ" by auto
next
fix t assume "t ∈ subst_range θ" thus "∃z ∈ subst_domain θ. t = θ z" by auto
qed
moreover have "subst_range θ ⊆ (λc. Fun c []) ` 𝒞⇩p⇩u⇩b - T"
using σ(3) δ(3) θ by (auto simp add: subst_domain_def)
moreover have "wt⇩s⇩u⇩b⇩s⇩t θ" using σ(4) δ(4) θ unfolding wt⇩s⇩u⇩b⇩s⇩t_def by auto
moreover have "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using θ σ(5) δ(5) wf_trm_subst_range_iff[of δ]
wf_trm_subst_range_iff[of σ] wf_trm_subst_range_iff[of θ]
by presburger
ultimately show ?case by blast
qed
theorem wt_sat_if_simple:
assumes "simple S" "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)"
and ℐ': "∀X F. Inequality X F ∈ set S ⟶ ineq_model ℐ' X F"
"ground (subst_range ℐ')"
"subst_domain ℐ' = {x ∈ vars⇩s⇩t S. ∃X F. Inequality X F ∈ set S ∧ x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X}"
and tfr_stp_all: "list_all tfr⇩s⇩t⇩p S"
shows "∃ℐ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ ∧ (ℐ ⊨⇩c ⟨S, θ⟩) ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
proof -
from ‹wf⇩c⇩o⇩n⇩s⇩t⇩r S θ› have "wf⇩s⇩t {} S" "subst_idem θ" and S_θ_disj: "∀v ∈ vars⇩s⇩t S. θ v = Var v"
using subst_idemI[of θ] unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def wf⇩s⇩u⇩b⇩s⇩t_def by force+
obtain ℐ::"('fun,'var) subst"
where ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "wt⇩s⇩u⇩b⇩s⇩t ℐ" "subst_range ℐ ⊆ public_ground_wf_terms"
using wt_interpretation_exists by blast
hence ℐ_deduct: "⋀x M. M ⊢⇩c ℐ x" and ℐ_wf_trm: "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
using pgwt_deducible pgwt_wellformed by fastforce+
let ?P = "λδ X. subst_domain δ = set X ∧ ground (subst_range δ)"
let ?Sineqsvars = "{x ∈ vars⇩s⇩t S. ∃X F. Inequality X F ∈ set S ∧ x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∧ x ∉ set X}"
let ?Strms = "subterms⇩s⇩e⇩t (trms⇩s⇩t S)"
have finite_vars: "finite ?Sineqsvars" "finite ?Strms" "wf⇩t⇩r⇩m⇩s ?Strms"
using wf_trm_subtermeq assms(5) by fastforce+
define Q1 where "Q1 = (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. ∃a. Γ (Var x) = TAtom a)"
define Q2 where "Q2 = (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))"
define Q1' where "Q1' = (λ(t::('fun,'var) term) (t'::('fun,'var) term) X.
∀x ∈ (fv t ∪ fv t') - set X. ∃a. Γ (Var x) = TAtom a)"
define Q2' where "Q2' = (λ(t::('fun,'var) term) (t'::('fun,'var) term) X.
∀f T. Fun f T ∈ subterms t ∪ subterms t' ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))"
have ex_P: "∀X. ∃δ. ?P δ X" using interpretation_subst_exists' by blast
have tfr_ineq: "∀X F. Inequality X F ∈ set S ⟶ Q1 F X ∨ Q2 F X"
using tfr_stp_all Q1_def Q2_def tfr⇩s⇩t⇩p_list_all_alt_def[of S] by blast
have S_fv_bvars_disj: "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}" using ‹wf⇩c⇩o⇩n⇩s⇩t⇩r S θ› unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def by metis
hence ineqs_vars_not_bound: "∀X F x. Inequality X F ∈ set S ⟶ x ∈ ?Sineqsvars ⟶ x ∉ set X"
using strand_fv_bvars_disjoint_unfold by blast
have θ_vars_S_bvars_disj: "(subst_domain θ ∪ range_vars θ) ∩ set X = {}"
when "Inequality X F ∈ set S" for F X
using wf_constr_bvars_disj[OF ‹wf⇩c⇩o⇩n⇩s⇩t⇩r S θ›]
strand_fv_bvars_disjointD(1)[OF S_fv_bvars_disj that]
by blast
obtain σ::"('fun,'var) subst"
where σ_fv_dom: "subst_domain σ = ?Sineqsvars"
and σ_subterm_inj: "subterm_inj_on σ (subst_domain σ)"
and σ_fresh_pub_img: "subterms⇩s⇩e⇩t (subst_range σ) ⊆ {t. {} ⊢⇩c t} - ?Strms"
and σ_wt: "wt⇩s⇩u⇩b⇩s⇩t σ"
and σ_wf_trm: "wf⇩t⇩r⇩m⇩s (subst_range σ)"
using wt_bij_finite_subst_exists[OF finite_vars]
subst_inj_on_is_bij_betw subterm_inj_on_alt_def'
by moura
have σ_bij_dom_img: "bij_betw σ (subst_domain σ) (subst_range σ)"
by (metis σ_subterm_inj subst_inj_on_is_bij_betw subterm_inj_on_alt_def)
have "finite (subst_domain σ)" by(metis σ_fv_dom finite_vars(1))
hence σ_finite_img: "finite (subst_range σ)" using σ_bij_dom_img bij_betw_finite by blast
have σ_img_subterms: "∀s ∈ subst_range σ. ∀u ∈ subst_range σ. (∃v. v ⊑ s ∧ v ⊑ u) ⟶ s = u"
by (metis σ_subterm_inj subterm_inj_on_alt_def')
have "subst_range σ ⊆ subterms⇩s⇩e⇩t (subst_range σ)" by auto
hence "subst_range σ ⊆ public_ground_wf_terms - ?Strms"
and σ_pgwt_img:
"subst_range σ ⊆ public_ground_wf_terms"
"subterms⇩s⇩e⇩t (subst_range σ) ⊆ public_ground_wf_terms"
using σ_fresh_pub_img pgwt_is_empty_synth by blast+
have σ_img_ground: "ground (subst_range σ)"
using σ_pgwt_img pgwt_ground by auto
hence σ_inj: "inj σ"
using σ_bij_dom_img subst_inj_is_bij_betw_dom_img_if_ground_img by auto
have σ_ineqs_fv_dom: "⋀X F. Inequality X F ∈ set S ⟹ fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ subst_domain σ"
using σ_fv_dom by fastforce
have σ_dom_bvars_disj: "∀X F. Inequality X F ∈ set S ⟶ subst_domain σ ∩ set X = {}"
using ineqs_vars_not_bound σ_fv_dom by fastforce
have ℐ'1: "∀X F δ. Inequality X F ∈ set S ⟶ fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ subst_domain ℐ'"
using ℐ'(3) ineqs_vars_not_bound by fastforce
have ℐ'2: "∀X F. Inequality X F ∈ set S ⟶ subst_domain ℐ' ∩ set X = {}"
using ℐ'(3) ineqs_vars_not_bound by blast
have doms_eq: "subst_domain ℐ' = subst_domain σ" using ℐ'(3) σ_fv_dom by simp
have σ_ineqs_neq: "ineq_model σ X F" when "Inequality X F ∈ set S" for X F
proof -
obtain a::"'fun" where a: "a ∉ ⋃(funs_term ` subterms⇩s⇩e⇩t (subst_range σ))"
using exists_fun_notin_funs_terms[OF subterms_union_finite[OF σ_finite_img]]
by moura
hence a': "⋀T. Fun a T ∉ subterms⇩s⇩e⇩t (subst_range σ)"
"⋀S. Fun a [] ∈ set (Fun a []#S)" "Fun a [] ∉ Var ` set X"
by (meson a UN_I term.set_intros(1), auto)
define t where "t ≡ Fun a (Fun a []#map fst F)"
define t' where "t' ≡ Fun a (Fun a []#map snd F)"
note F_in = that
have t_fv: "fv t ∪ fv t' ⊆ fv⇩p⇩a⇩i⇩r⇩s F"
unfolding t_def t'_def by force
have t_subterms: "subterms t ∪ subterms t' ⊆ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ∪ {t, t', Fun a []}"
unfolding t_def t'_def by force
have "t ⋅ δ ⋅ σ ≠ t' ⋅ δ ⋅ σ" when "?P δ X" for δ
proof -
have tfr_assms: "Q1 F X ∨ Q2 F X" using tfr_ineq F_in by metis
have "Q1 F X ⟹ ∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. ∃c. σ x = Fun c []"
proof
fix x assume "Q1 F X" and x: "x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X"
then obtain a where "Γ (Var x) = TAtom a" unfolding Q1_def by moura
hence a: "Γ (σ x) = TAtom a" using σ_wt unfolding wt⇩s⇩u⇩b⇩s⇩t_def by simp
have "x ∈ subst_domain σ" using σ_ineqs_fv_dom x F_in by auto
then obtain f T where fT: "σ x = Fun f T" by (meson σ_img_ground ground_img_obtain_fun)
hence "T = []" using σ_wf_trm a TAtom_term_cases by fastforce
thus "∃c. σ x = Fun c []" using fT by metis
qed
hence 1: "Q1 F X ⟹ ∀x ∈ (fv t ∪ fv t') - set X. ∃c. σ x = Fun c []"
using t_fv by auto
have 2: "¬Q1 F X ⟹ Q2 F X" by (metis tfr_assms)
have 3: "subst_domain σ ∩ set X = {}" using σ_dom_bvars_disj F_in by auto
have 4: "subterms⇩s⇩e⇩t (subst_range σ) ∩ (subterms t ∪ subterms t') = {}"
proof -
define M1 where "M1 ≡ {t, t', Fun a []}"
define M2 where "M2 ≡ ?Strms"
have "subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⊆ M2"
using F_in unfolding M2_def by force
moreover have "subterms t ∪ subterms t' ⊆ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ∪ M1"
using t_subterms unfolding M1_def by blast
ultimately have *: "subterms t ∪ subterms t' ⊆ M2 ∪ M1"
by auto
have "subterms⇩s⇩e⇩t (subst_range σ) ∩ M1 = {}"
"subterms⇩s⇩e⇩t (subst_range σ) ∩ M2 = {}"
using a' σ_fresh_pub_img
unfolding t_def t'_def M1_def M2_def
by blast+
thus ?thesis using * by blast
qed
have 5: "(fv t ∪ fv t') - subst_domain σ ⊆ set X"
using σ_ineqs_fv_dom[OF F_in] t_fv
by auto
have 6: "∀δ. ?P δ X ⟶ t ⋅ δ ⋅ ℐ' ≠ t' ⋅ δ ⋅ ℐ'"
by (metis t_def t'_def ℐ'(1) F_in ineq_model_singleE ineq_model_single_iff)
have 7: "fv t ∪ fv t' - set X ⊆ subst_domain ℐ'" using ℐ'1 F_in t_fv by force
have 8: "subst_domain ℐ' ∩ set X = {}" using ℐ'2 F_in by auto
have 9: "Q1' t t' X" when "Q1 F X"
using that t_fv
unfolding Q1_def Q1'_def t_def t'_def
by blast
have 10: "Q2' t t' X" when "Q2 F X" unfolding Q2'_def
proof (intro allI impI)
fix f T assume "Fun f T ∈ subterms t ∪ subterms t'"
moreover {
assume "Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F)"
hence "T = [] ∨ (∃s∈set T. s ∉ Var ` set X)" by (metis Q2_def that)
} moreover {
assume "Fun f T = t" hence "T = [] ∨ (∃s∈set T. s ∉ Var ` set X)"
unfolding t_def using a'(2,3) by simp
} moreover {
assume "Fun f T = t'" hence "T = [] ∨ (∃s∈set T. s ∉ Var ` set X)"
unfolding t'_def using a'(2,3) by simp
} moreover {
assume "Fun f T = Fun a []" hence "T = [] ∨ (∃s∈set T. s ∉ Var ` set X)" by simp
} ultimately show "T = [] ∨ (∃s∈set T. s ∉ Var ` set X)" using t_subterms by blast
qed
note 11 = σ_subterm_inj σ_img_ground 3 4 5
note 12 = 6 7 8 ℐ'(2) doms_eq
show "t ⋅ δ ⋅ σ ≠ t' ⋅ δ ⋅ σ"
using 1 2 9 10 that sat_ineq_subterm_inj_subst[OF 11 _ 12]
unfolding Q1'_def Q2'_def by metis
qed
thus ?thesis by (metis t_def t'_def ineq_model_singleI ineq_model_single_iff)
qed
have σ_ineqs_fv_dom': "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆ subst_domain σ"
when "Inequality X F ∈ set S" and "?P δ X" for F δ X
using σ_ineqs_fv_dom[OF that(1)]
proof (induction F)
case (Cons g G)
obtain t t' where g: "g = (t,t')" by (metis surj_pair)
hence "fv⇩p⇩a⇩i⇩r⇩s (g#G ⋅⇩p⇩a⇩i⇩r⇩s δ) = fv (t ⋅ δ) ∪ fv (t' ⋅ δ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s δ)"
"fv⇩p⇩a⇩i⇩r⇩s (g#G) = fv t ∪ fv t' ∪ fv⇩p⇩a⇩i⇩r⇩s G"
by (simp_all add: subst_apply_pairs_def)
moreover have "fv (t ⋅ δ) = fv t - subst_domain δ" "fv (t' ⋅ δ) = fv t' - subst_domain δ"
using g that(2) by (simp_all add: subst_fv_unfold_ground_img range_vars_alt_def)
moreover have "fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆ subst_domain σ" using Cons by auto
ultimately show ?case using Cons.prems that(2) by auto
qed (simp add: subst_apply_pairs_def)
have σ_ineqs_ground: "fv⇩p⇩a⇩i⇩r⇩s ((F ⋅⇩p⇩a⇩i⇩r⇩s δ) ⋅⇩p⇩a⇩i⇩r⇩s σ) = {}"
when "Inequality X F ∈ set S" and "?P δ X" for F δ X
using σ_ineqs_fv_dom'[OF that]
proof (induction F)
case (Cons g G)
obtain t t' where g: "g = (t,t')" by (metis surj_pair)
hence "fv (t ⋅ δ) ⊆ subst_domain σ" "fv (t' ⋅ δ) ⊆ subst_domain σ"
using Cons.prems by (auto simp add: subst_apply_pairs_def)
hence "fv (t ⋅ δ ⋅ σ) = {}" "fv (t' ⋅ δ ⋅ σ) = {}"
using subst_fv_dom_ground_if_ground_img[OF _ σ_img_ground] by metis+
thus ?case using g Cons by (auto simp add: subst_apply_pairs_def)
qed (simp add: subst_apply_pairs_def)
from σ_pgwt_img σ_ineqs_neq have σ_deduct: "M ⊢⇩c σ x" when "x ∈ subst_domain σ" for x M
using that pgwt_deducible by fastforce
{ fix M::"('fun,'var) terms"
have "⟦M; S⟧⇩c (θ ∘⇩s σ ∘⇩s ℐ)"
using ‹wf⇩s⇩t {} S› ‹simple S› S_θ_disj σ_ineqs_neq σ_ineqs_fv_dom' θ_vars_S_bvars_disj
proof (induction S arbitrary: M rule: wf⇩s⇩t_simple_induct)
case (ConsSnd v S)
hence S_sat: "⟦M; S⟧⇩c (θ ∘⇩s σ ∘⇩s ℐ)" and "θ v = Var v" by auto
hence "⋀M. M ⊢⇩c Var v ⋅ (θ ∘⇩s σ ∘⇩s ℐ)"
using ℐ_deduct σ_deduct
by (metis ideduct_synth_subst_apply subst_apply_term.simps(1)
subst_subst_compose trm_subst_ident')
thus ?case using strand_sem_append(1)[OF S_sat] by (metis strand_sem_c.simps(1,2))
next
case (ConsIneq X F S)
have dom_disj: "subst_domain θ ∩ fv⇩p⇩a⇩i⇩r⇩s F = {}"
using ConsIneq.prems(1) subst_dom_vars_in_subst
by force
hence *: "F ⋅⇩p⇩a⇩i⇩r⇩s θ = F" by blast
have **: "ineq_model σ X F" by (meson ConsIneq.prems(2) in_set_conv_decomp)
have "⋀x. x ∈ vars⇩s⇩t S ⟹ x ∈ vars⇩s⇩t (S@[Inequality X F])"
"⋀x. x ∈ set S ⟹ x ∈ set (S@[Inequality X F])" by auto
hence IH: "⟦M; S⟧⇩c (θ ∘⇩s σ ∘⇩s ℐ)" by (metis ConsIneq.IH ConsIneq.prems(1,2,3,4))
have "ineq_model (σ ∘⇩s ℐ) X F"
proof -
have "fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s δ) ⊆ subst_domain σ" when "?P δ X" for δ
using ConsIneq.prems(3)[OF _ that] by simp
hence "fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ subst_domain σ"
using fv⇩p⇩a⇩i⇩r⇩s_subst_subset ex_P
by (metis Diff_subset_conv Un_commute)
thus ?thesis by (metis ineq_model_ground_subst[OF _ σ_img_ground **])
qed
hence "ineq_model (θ ∘⇩s σ ∘⇩s ℐ) X F"
using * ineq_model_subst' subst_compose_assoc ConsIneq.prems(4)
by (metis UnCI list.set_intros(1) set_append)
thus ?case using IH by (auto simp add: ineq_model_def)
qed auto
}
moreover have "wt⇩s⇩u⇩b⇩s⇩t (θ ∘⇩s σ ∘⇩s ℐ)" "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s σ ∘⇩s ℐ))"
by (metis wt_subst_compose ‹wt⇩s⇩u⇩b⇩s⇩t θ› ‹wt⇩s⇩u⇩b⇩s⇩t σ› ‹wt⇩s⇩u⇩b⇩s⇩t ℐ›,
metis assms(4) ℐ_wf_trm σ_wf_trm wf_trm_subst subst_img_comp_subset')
ultimately show ?thesis
using interpretation_comp(1)[OF ‹interpretation⇩s⇩u⇩b⇩s⇩t ℐ›, of "θ ∘⇩s σ"]
subst_idem_support[OF ‹subst_idem θ›, of "σ ∘⇩s ℐ"] subst_compose_assoc
unfolding constr_sem_c_def by metis
qed
end
subsubsection ‹Theorem: Type-flaw resistant constraints are well-typed satisfiable (composition-only)›
text ‹
There exists well-typed models of satisfiable type-flaw resistant constraints in the
semantics where the intruder is limited to composition only (i.e., he cannot perform
decomposition/analysis of deducible messages).
›
theorem wt_attack_if_tfr_attack:
assumes "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and "ℐ ⊨⇩c ⟨S, θ⟩"
and "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ"
and "wt⇩s⇩u⇩b⇩s⇩t θ"
and "tfr⇩s⇩t S"
and "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)"
and "wf⇩t⇩r⇩m⇩s (subst_range θ)"
obtains ℐ⇩τ where "interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ"
and "ℐ⇩τ ⊨⇩c ⟨S, θ⟩"
and "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ"
and "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
proof -
have tfr: "tfr⇩s⇩e⇩t (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)" "list_all tfr⇩s⇩t⇩p S"
using assms(5,6) unfolding tfr⇩s⇩t_def by metis+
obtain S' θ' where *: "simple S'" "(S,θ) ↝⇧* (S',θ')" "⟦{}; S'⟧⇩c ℐ"
using LI_completeness[OF assms(3,2)] unfolding constr_sem_c_def
by (meson term.order_refl)
have **: "wf⇩c⇩o⇩n⇩s⇩t⇩r S' θ'" "wt⇩s⇩u⇩b⇩s⇩t θ'" "list_all tfr⇩s⇩t⇩p S'" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S')" "wf⇩t⇩r⇩m⇩s (subst_range θ')"
using LI_preserves_welltypedness[OF *(2) assms(3,4,7) tfr]
LI_preserves_wellformedness[OF *(2) assms(3)]
LI_preserves_tfr[OF *(2) assms(3,4,7) tfr]
by metis+
define A where "A ≡ {x ∈ vars⇩s⇩t S'. ∃X F. Inequality X F ∈ set S' ∧ x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∧ x ∉ set X}"
define B where "B ≡ UNIV - A"
let ?ℐ = "rm_vars B ℐ"
have grℐ: "ground (subst_range ℐ)" "ground (subst_range ?ℐ)"
using assms(1) rm_vars_img_subset[of B ℐ] by (auto simp add: subst_domain_def)
{ fix X F
assume "Inequality X F ∈ set S'"
hence *: "ineq_model ℐ X F"
using strand_sem_c_imp_ineq_model[OF *(3)]
by (auto simp del: subst_range.simps)
hence "ineq_model ?ℐ X F"
proof -
{ fix δ
assume 1: "subst_domain δ = set X" "ground (subst_range δ)"
and 2: "list_ex (λf. fst f ⋅ δ ∘⇩s ℐ ≠ snd f ⋅ δ ∘⇩s ℐ) F"
have "list_ex (λf. fst f ⋅ δ ∘⇩s rm_vars B ℐ ≠ snd f ⋅ δ ∘⇩s rm_vars B ℐ) F" using 2
proof (induction F)
case (Cons g G)
obtain t t' where g: "g = (t,t')" by (metis surj_pair)
thus ?case
using Cons Unifier_ground_rm_vars[OF grℐ(1), of "t ⋅ δ" B "t' ⋅ δ"]
by auto
qed simp
} thus ?thesis using * unfolding ineq_model_def by simp
qed
} moreover have "subst_domain ℐ = UNIV" using assms(1) by metis
hence "subst_domain ?ℐ = A" using rm_vars_dom[of B ℐ] B_def by blast
ultimately obtain ℐ⇩τ where
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "ℐ⇩τ ⊨⇩c ⟨S', θ'⟩" "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
using wt_sat_if_simple[OF *(1) **(1,2,5,4) _ grℐ(2) _ **(3)] A_def
by (auto simp del: subst_range.simps)
thus ?thesis using that LI_soundness[OF assms(3) *(2)] by metis
qed
text ‹
Contra-positive version: if a type-flaw resistant constraint does not have a well-typed model
then it is unsatisfiable
›
corollary secure_if_wt_secure:
assumes "¬(∃ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ (ℐ⇩τ ⊨⇩c ⟨S, θ⟩) ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ)"
and "wf⇩c⇩o⇩n⇩s⇩t⇩r S θ" "wt⇩s⇩u⇩b⇩s⇩t θ" "tfr⇩s⇩t S"
and "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t S)" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
shows "¬(∃ℐ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ ∧ (ℐ ⊨⇩c ⟨S, θ⟩))"
using wt_attack_if_tfr_attack[OF _ _ assms(2,3,4,5,6)] assms(1) by metis
end
subsection ‹Lifting the Composition-Only Typing Result to the Full Intruder Model›
context typed_model
begin
subsubsection ‹Analysis Invariance›
definition (in typed_model) Ana_invar_subst where
"Ana_invar_subst ℳ ≡
(∀f T K M δ. Fun f T ∈ (subterms⇩s⇩e⇩t ℳ) ⟶
Ana (Fun f T) = (K, M) ⟶ Ana (Fun f T ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ, M ⋅⇩l⇩i⇩s⇩t δ))"
lemma (in typed_model) Ana_invar_subst_subset:
assumes "Ana_invar_subst M" "N ⊆ M"
shows "Ana_invar_subst N"
using assms unfolding Ana_invar_subst_def by blast
lemma (in typed_model) Ana_invar_substD:
assumes "Ana_invar_subst ℳ"
and "Fun f T ∈ subterms⇩s⇩e⇩t ℳ" "Ana (Fun f T) = (K, M)"
shows "Ana (Fun f T ⋅ ℐ) = (K ⋅⇩l⇩i⇩s⇩t ℐ, M ⋅⇩l⇩i⇩s⇩t ℐ)"
using assms Ana_invar_subst_def by blast
end
subsubsection ‹Preliminary Definitions›
text ‹Strands extended with "decomposition steps"›
datatype (funs⇩e⇩s⇩t⇩p: 'a, vars⇩e⇩s⇩t⇩p: 'b) extstrand_step =
Step "('a,'b) strand_step"
| Decomp "('a,'b) term"
context typed_model
begin
context
begin
private fun trms⇩e⇩s⇩t⇩p where
"trms⇩e⇩s⇩t⇩p (Step x) = trms⇩s⇩t⇩p x"
| "trms⇩e⇩s⇩t⇩p (Decomp t) = {t}"
private abbreviation trms⇩e⇩s⇩t where "trms⇩e⇩s⇩t S ≡ ⋃(trms⇩e⇩s⇩t⇩p ` set S)"
private type_synonym ('a,'b) extstrand = "('a,'b) extstrand_step list"
private type_synonym ('a,'b) extstrands = "('a,'b) extstrand set"
private definition decomp::"('fun,'var) term ⇒ ('fun,'var) strand" where
"decomp t ≡ (case (Ana t) of (K,T) ⇒ send⟨t⟩⇩s⇩t#map Send K@map Receive T)"
private fun to_st where
"to_st [] = []"
| "to_st (Step x#S) = x#(to_st S)"
| "to_st (Decomp t#S) = (decomp t)@(to_st S)"
private fun to_est where
"to_est [] = []"
| "to_est (x#S) = Step x#to_est S"
private abbreviation "ik⇩e⇩s⇩t A ≡ ik⇩s⇩t (to_st A)"
private abbreviation "wf⇩e⇩s⇩t V A ≡ wf⇩s⇩t V (to_st A)"
private abbreviation "assignment_rhs⇩e⇩s⇩t A ≡ assignment_rhs⇩s⇩t (to_st A)"
private abbreviation "vars⇩e⇩s⇩t A ≡ vars⇩s⇩t (to_st A)"
private abbreviation "wfrestrictedvars⇩e⇩s⇩t A ≡ wfrestrictedvars⇩s⇩t (to_st A)"
private abbreviation "bvars⇩e⇩s⇩t A ≡ bvars⇩s⇩t (to_st A)"
private abbreviation "fv⇩e⇩s⇩t A ≡ fv⇩s⇩t (to_st A)"
private abbreviation "funs⇩e⇩s⇩t A ≡ funs⇩s⇩t (to_st A)"
private definition wf⇩s⇩t⇩s'::"('fun,'var) strands ⇒ ('fun,'var) extstrand ⇒ bool" where
"wf⇩s⇩t⇩s' 𝒮 𝒜 ≡ (∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t 𝒜) (dual⇩s⇩t S)) ∧
(∀S ∈ 𝒮. ∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}) ∧
(∀S ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t 𝒜 = {}) ∧
(∀S ∈ 𝒮. fv⇩s⇩t (to_st 𝒜) ∩ bvars⇩s⇩t S = {})"
private definition wf⇩s⇩t⇩s::"('fun,'var) strands ⇒ bool" where
"wf⇩s⇩t⇩s 𝒮 ≡ (∀S ∈ 𝒮. wf⇩s⇩t {} (dual⇩s⇩t S)) ∧ (∀S ∈ 𝒮. ∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {})"
private inductive well_analyzed::"('fun,'var) extstrand ⇒ bool" where
Nil[simp]: "well_analyzed []"
| Step: "well_analyzed A ⟹ well_analyzed (A@[Step x])"
| Decomp: "⟦well_analyzed A; t ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A) - (Var ` 𝒱)⟧
⟹ well_analyzed (A@[Decomp t])"
private fun subst_apply_extstrandstep (infix "⋅⇩e⇩s⇩t⇩p" 51) where
"subst_apply_extstrandstep (Step x) θ = Step (x ⋅⇩s⇩t⇩p θ)"
| "subst_apply_extstrandstep (Decomp t) θ = Decomp (t ⋅ θ)"
private lemma subst_apply_extstrandstep'_simps[simp]:
"(Step (send⟨t⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ = Step (send⟨t ⋅ θ⟩⇩s⇩t)"
"(Step (receive⟨t⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ = Step (receive⟨t ⋅ θ⟩⇩s⇩t)"
"(Step (⟨a: t ≐ t'⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ = Step (⟨a: (t ⋅ θ) ≐ (t' ⋅ θ)⟩⇩s⇩t)"
"(Step (∀X⟨∨≠: F⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ = Step (∀X⟨∨≠: (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)⟩⇩s⇩t)"
by simp_all
private lemma vars⇩e⇩s⇩t⇩p_subst_apply_simps[simp]:
"vars⇩e⇩s⇩t⇩p ((Step (send⟨t⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ) = fv (t ⋅ θ)"
"vars⇩e⇩s⇩t⇩p ((Step (receive⟨t⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ) = fv (t ⋅ θ)"
"vars⇩e⇩s⇩t⇩p ((Step (⟨a: t ≐ t'⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (t' ⋅ θ)"
"vars⇩e⇩s⇩t⇩p ((Step (∀X⟨∨≠: F⟩⇩s⇩t)) ⋅⇩e⇩s⇩t⇩p θ) = set X ∪ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)"
by auto
private definition subst_apply_extstrand (infix "⋅⇩e⇩s⇩t" 51) where "S ⋅⇩e⇩s⇩t θ ≡ map (λx. x ⋅⇩e⇩s⇩t⇩p θ) S"
private abbreviation update⇩s⇩t::"('fun,'var) strands ⇒ ('fun,'var) strand ⇒ ('fun,'var) strands"
where
"update⇩s⇩t 𝒮 S ≡ (case S of Nil ⇒ 𝒮 - {S} | Cons _ S' ⇒ insert S' (𝒮 - {S}))"
private inductive_set decomps⇩e⇩s⇩t::
"('fun,'var) terms ⇒ ('fun,'var) terms ⇒ ('fun,'var) subst ⇒ ('fun,'var) extstrands"
for ℳ and 𝒩 and ℐ where
Nil: "[] ∈ decomps⇩e⇩s⇩t ℳ 𝒩 ℐ"
| Decomp: "⟦𝒟 ∈ decomps⇩e⇩s⇩t ℳ 𝒩 ℐ; Fun f T ∈ subterms⇩s⇩e⇩t (ℳ ∪ 𝒩);
Ana (Fun f T) = (K,M); M ≠ [];
(ℳ ∪ ik⇩e⇩s⇩t 𝒟) ⋅⇩s⇩e⇩t ℐ ⊢⇩c Fun f T ⋅ ℐ;
⋀k. k ∈ set K ⟹ (ℳ ∪ ik⇩e⇩s⇩t 𝒟) ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ⟧
⟹ 𝒟@[Decomp (Fun f T)] ∈ decomps⇩e⇩s⇩t ℳ 𝒩 ℐ"
private fun decomp_rm⇩e⇩s⇩t::"('fun,'var) extstrand ⇒ ('fun,'var) extstrand" where
"decomp_rm⇩e⇩s⇩t [] = []"
| "decomp_rm⇩e⇩s⇩t (Decomp t#S) = decomp_rm⇩e⇩s⇩t S"
| "decomp_rm⇩e⇩s⇩t (Step x#S) = Step x#(decomp_rm⇩e⇩s⇩t S)"
private inductive sem⇩e⇩s⇩t_d::"('fun,'var) terms ⇒ ('fun,'var) subst ⇒ ('fun,'var) extstrand ⇒ bool"
where
Nil[simp]: "sem⇩e⇩s⇩t_d M⇩0 ℐ []"
| Send: "sem⇩e⇩s⇩t_d M⇩0 ℐ S ⟹ (ik⇩e⇩s⇩t S ∪ M⇩0) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ ⟹ sem⇩e⇩s⇩t_d M⇩0 ℐ (S@[Step (send⟨t⟩⇩s⇩t)])"
| Receive: "sem⇩e⇩s⇩t_d M⇩0 ℐ S ⟹ sem⇩e⇩s⇩t_d M⇩0 ℐ (S@[Step (receive⟨t⟩⇩s⇩t)])"
| Equality: "sem⇩e⇩s⇩t_d M⇩0 ℐ S ⟹ t ⋅ ℐ = t' ⋅ ℐ ⟹ sem⇩e⇩s⇩t_d M⇩0 ℐ (S@[Step (⟨a: t ≐ t'⟩⇩s⇩t)])"
| Inequality: "sem⇩e⇩s⇩t_d M⇩0 ℐ S
⟹ ineq_model ℐ X F
⟹ sem⇩e⇩s⇩t_d M⇩0 ℐ (S@[Step (∀X⟨∨≠: F⟩⇩s⇩t)])"
| Decompose: "sem⇩e⇩s⇩t_d M⇩0 ℐ S ⟹ (ik⇩e⇩s⇩t S ∪ M⇩0) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ ⟹ Ana t = (K, M)
⟹ (⋀k. k ∈ set K ⟹ (ik⇩e⇩s⇩t S ∪ M⇩0) ⋅⇩s⇩e⇩t ℐ ⊢ k ⋅ ℐ) ⟹ sem⇩e⇩s⇩t_d M⇩0 ℐ (S@[Decomp t])"
private inductive sem⇩e⇩s⇩t_c::"('fun,'var) terms ⇒ ('fun,'var) subst ⇒ ('fun,'var) extstrand ⇒ bool"
where
Nil[simp]: "sem⇩e⇩s⇩t_c M⇩0 ℐ []"
| Send: "sem⇩e⇩s⇩t_c M⇩0 ℐ S ⟹ (ik⇩e⇩s⇩t S ∪ M⇩0) ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ ⟹ sem⇩e⇩s⇩t_c M⇩0 ℐ (S@[Step (send⟨t⟩⇩s⇩t)])"
| Receive: "sem⇩e⇩s⇩t_c M⇩0 ℐ S ⟹ sem⇩e⇩s⇩t_c M⇩0 ℐ (S@[Step (receive⟨t⟩⇩s⇩t)])"
| Equality: "sem⇩e⇩s⇩t_c M⇩0 ℐ S ⟹ t ⋅ ℐ = t' ⋅ ℐ ⟹ sem⇩e⇩s⇩t_c M⇩0 ℐ (S@[Step (⟨a: t ≐ t'⟩⇩s⇩t)])"
| Inequality: "sem⇩e⇩s⇩t_c M⇩0 ℐ S
⟹ ineq_model ℐ X F
⟹ sem⇩e⇩s⇩t_c M⇩0 ℐ (S@[Step (∀X⟨∨≠: F⟩⇩s⇩t)])"
| Decompose: "sem⇩e⇩s⇩t_c M⇩0 ℐ S ⟹ (ik⇩e⇩s⇩t S ∪ M⇩0) ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ ⟹ Ana t = (K, M)
⟹ (⋀k. k ∈ set K ⟹ (ik⇩e⇩s⇩t S ∪ M⇩0) ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ) ⟹ sem⇩e⇩s⇩t_c M⇩0 ℐ (S@[Decomp t])"
subsubsection ‹Preliminary Lemmata›
private lemma wf⇩s⇩t⇩s_wf⇩s⇩t⇩s':
"wf⇩s⇩t⇩s 𝒮 = wf⇩s⇩t⇩s' 𝒮 []"
by (simp add: wf⇩s⇩t⇩s_def wf⇩s⇩t⇩s'_def)
private lemma decomp_ik:
assumes "Ana t = (K,M)"
shows "ik⇩s⇩t (decomp t) = set M"
using ik_rcv_map[of _ M] ik_rcv_map'[of _ M]
by (auto simp add: decomp_def inv_def assms)
private lemma decomp_assignment_rhs_empty:
assumes "Ana t = (K,M)"
shows "assignment_rhs⇩s⇩t (decomp t) = {}"
by (auto simp add: decomp_def inv_def assms)
private lemma decomp_tfr⇩s⇩t⇩p:
"list_all tfr⇩s⇩t⇩p (decomp t)"
by (auto simp add: decomp_def list_all_def)
private lemma trms⇩e⇩s⇩t_ikI:
"t ∈ ik⇩e⇩s⇩t A ⟹ t ∈ subterms⇩s⇩e⇩t (trms⇩e⇩s⇩t A)"
proof (induction A rule: to_st.induct)
case (2 x S) thus ?case by (cases x) auto
next
case (3 t' A)
obtain K M where Ana: "Ana t' = (K,M)" by (metis surj_pair)
show ?case using 3 decomp_ik[OF Ana] Ana_subterm[OF Ana] by auto
qed simp
private lemma trms⇩e⇩s⇩t_ik_assignment_rhsI:
"t ∈ ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A ⟹ t ∈ subterms⇩s⇩e⇩t (trms⇩e⇩s⇩t A)"
proof (induction A rule: to_st.induct)
case (2 x S) thus ?case
proof (cases x)
case (Equality ac t t') thus ?thesis using 2 by (cases ac) auto
qed auto
next
case (3 t' A)
obtain K M where Ana: "Ana t' = (K,M)" by (metis surj_pair)
show ?case
using 3 decomp_ik[OF Ana] decomp_assignment_rhs_empty[OF Ana] Ana_subterm[OF Ana]
by auto
qed simp
private lemma trms⇩e⇩s⇩t_ik_subtermsI:
assumes "t ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A)"
shows "t ∈ subterms⇩s⇩e⇩t (trms⇩e⇩s⇩t A)"
proof -
obtain t' where "t' ∈ ik⇩e⇩s⇩t A" "t ⊑ t'" using trms⇩e⇩s⇩t_ikI assms by auto
thus ?thesis by (meson contra_subsetD in_subterms_subset_Union trms⇩e⇩s⇩t_ikI)
qed
private lemma trms⇩e⇩s⇩tD:
assumes "t ∈ trms⇩e⇩s⇩t A"
shows "t ∈ trms⇩s⇩t (to_st A)"
using assms
proof (induction A)
case (Cons a A)
obtain K M where Ana: "Ana t = (K,M)" by (metis surj_pair)
hence "t ∈ trms⇩s⇩t (decomp t)" unfolding decomp_def by force
thus ?case using Cons.IH Cons.prems by (cases a) auto
qed simp
private lemma subst_apply_extstrand_nil[simp]:
"[] ⋅⇩e⇩s⇩t θ = []"
by (simp add: subst_apply_extstrand_def)
private lemma subst_apply_extstrand_singleton[simp]:
"[Step (receive⟨t⟩⇩s⇩t)] ⋅⇩e⇩s⇩t θ = [Step (Receive (t ⋅ θ))]"
"[Step (send⟨t⟩⇩s⇩t)] ⋅⇩e⇩s⇩t θ = [Step (Send (t ⋅ θ))]"
"[Step (⟨a: t ≐ t'⟩⇩s⇩t)] ⋅⇩e⇩s⇩t θ = [Step (Equality a (t ⋅ θ) (t' ⋅ θ))]"
"[Decomp t] ⋅⇩e⇩s⇩t θ = [Decomp (t ⋅ θ)]"
unfolding subst_apply_extstrand_def by auto
private lemma extstrand_subst_hom:
"(S@S') ⋅⇩e⇩s⇩t θ = (S ⋅⇩e⇩s⇩t θ)@(S' ⋅⇩e⇩s⇩t θ)" "(x#S) ⋅⇩e⇩s⇩t θ = (x ⋅⇩e⇩s⇩t⇩p θ)#(S ⋅⇩e⇩s⇩t θ)"
unfolding subst_apply_extstrand_def by auto
private lemma decomp_vars:
"wfrestrictedvars⇩s⇩t (decomp t) = fv t" "vars⇩s⇩t (decomp t) = fv t" "bvars⇩s⇩t (decomp t) = {}"
"fv⇩s⇩t (decomp t) = fv t"
proof -
obtain K M where Ana: "Ana t = (K,M)" by (metis surj_pair)
hence "decomp t = send⟨t⟩⇩s⇩t#map Send K@map Receive M"
unfolding decomp_def by simp
moreover have "⋃(set (map fv K)) = fv⇩s⇩e⇩t (set K)" "⋃(set (map fv M)) = fv⇩s⇩e⇩t (set M)" by auto
moreover have "fv⇩s⇩e⇩t (set K) ⊆ fv t" "fv⇩s⇩e⇩t (set M) ⊆ fv t"
using Ana_subterm[OF Ana(1)] Ana_keys_fv[OF Ana(1)]
by (simp_all add: UN_least psubsetD subtermeq_vars_subset)
ultimately show
"wfrestrictedvars⇩s⇩t (decomp t) = fv t" "vars⇩s⇩t (decomp t) = fv t" "bvars⇩s⇩t (decomp t) = {}"
"fv⇩s⇩t (decomp t) = fv t"
by auto
qed
private lemma bvars⇩e⇩s⇩t_cons: "bvars⇩e⇩s⇩t (x#X) = bvars⇩e⇩s⇩t [x] ∪ bvars⇩e⇩s⇩t X"
by (cases x) auto
private lemma bvars⇩e⇩s⇩t_append: "bvars⇩e⇩s⇩t (A@B) = bvars⇩e⇩s⇩t A ∪ bvars⇩e⇩s⇩t B"
proof (induction A)
case (Cons x A) thus ?case using bvars⇩e⇩s⇩t_cons[of x "A@B"] bvars⇩e⇩s⇩t_cons[of x A] by force
qed simp
private lemma fv⇩e⇩s⇩t_cons: "fv⇩e⇩s⇩t (x#X) = fv⇩e⇩s⇩t [x] ∪ fv⇩e⇩s⇩t X"
by (cases x) auto
private lemma fv⇩e⇩s⇩t_append: "fv⇩e⇩s⇩t (A@B) = fv⇩e⇩s⇩t A ∪ fv⇩e⇩s⇩t B"
proof (induction A)
case (Cons x A) thus ?case using fv⇩e⇩s⇩t_cons[of x "A@B"] fv⇩e⇩s⇩t_cons[of x A] by auto
qed simp
private lemma bvars_decomp: "bvars⇩e⇩s⇩t (A@[Decomp t]) = bvars⇩e⇩s⇩t A" "bvars⇩e⇩s⇩t (Decomp t#A) = bvars⇩e⇩s⇩t A"
using bvars⇩e⇩s⇩t_append decomp_vars(3) by fastforce+
private lemma bvars_decomp_rm: "bvars⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) = bvars⇩e⇩s⇩t A"
using bvars_decomp by (induct A rule: decomp_rm⇩e⇩s⇩t.induct) simp_all+
private lemma fv_decomp_rm: "fv⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⊆ fv⇩e⇩s⇩t A"
by (induct A rule: decomp_rm⇩e⇩s⇩t.induct) auto
private lemma ik_assignment_rhs_decomp_fv:
assumes "t ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
shows "fv⇩e⇩s⇩t (A@[Decomp t]) = fv⇩e⇩s⇩t A"
proof -
have "fv⇩e⇩s⇩t (A@[Decomp t]) = fv⇩e⇩s⇩t A ∪ fv t" using fv⇩e⇩s⇩t_append decomp_vars by simp
moreover have "fv⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A) ⊆ fv⇩e⇩s⇩t A" by force
moreover have "fv t ⊆ fv⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
using fv_subset_subterms[OF assms(1)] by simp
ultimately show ?thesis by blast
qed
private lemma wfrestrictedvars⇩e⇩s⇩t_decomp_rm⇩e⇩s⇩t_subset:
"wfrestrictedvars⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⊆ wfrestrictedvars⇩e⇩s⇩t A"
by (induct A rule: decomp_rm⇩e⇩s⇩t.induct) auto+
private lemma wfrestrictedvars⇩e⇩s⇩t_eq_wfrestrictedvars⇩s⇩t:
"wfrestrictedvars⇩e⇩s⇩t A = wfrestrictedvars⇩s⇩t (to_st A)"
by simp
private lemma decomp_set_unfold:
assumes "Ana t = (K, M)"
shows "set (decomp t) = {send⟨t⟩⇩s⇩t} ∪ (Send ` set K) ∪ (Receive ` set M)"
using assms unfolding decomp_def by auto
private lemma ik⇩e⇩s⇩t_finite: "finite (ik⇩e⇩s⇩t A)"
by (rule finite_ik⇩s⇩t)
private lemma assignment_rhs⇩e⇩s⇩t_finite: "finite (assignment_rhs⇩e⇩s⇩t A)"
by (rule finite_assignment_rhs⇩s⇩t)
private lemma to_est_append: "to_est (A@B) = to_est A@to_est B"
by (induct A rule: to_est.induct) auto
private lemma to_st_to_est_inv: "to_st (to_est A) = A"
by (induct A rule: to_est.induct) auto
private lemma to_st_append: "to_st (A@B) = (to_st A)@(to_st B)"
by (induct A rule: to_st.induct) auto
private lemma to_st_cons: "to_st (a#B) = (to_st [a])@(to_st B)"
using to_st_append[of "[a]" B] by simp
private lemma wfrestrictedvars⇩e⇩s⇩t_split:
"wfrestrictedvars⇩e⇩s⇩t (x#S) = wfrestrictedvars⇩e⇩s⇩t [x] ∪ wfrestrictedvars⇩e⇩s⇩t S"
"wfrestrictedvars⇩e⇩s⇩t (S@S') = wfrestrictedvars⇩e⇩s⇩t S ∪ wfrestrictedvars⇩e⇩s⇩t S'"
using to_st_cons[of x S] to_st_append[of S S'] by auto
private lemma ik⇩e⇩s⇩t_append: "ik⇩e⇩s⇩t (A@B) = ik⇩e⇩s⇩t A ∪ ik⇩e⇩s⇩t B"
by (metis ik_append to_st_append)
private lemma assignment_rhs⇩e⇩s⇩t_append:
"assignment_rhs⇩e⇩s⇩t (A@B) = assignment_rhs⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t B"
by (metis assignment_rhs_append to_st_append)
private lemma ik⇩e⇩s⇩t_cons: "ik⇩e⇩s⇩t (a#A) = ik⇩e⇩s⇩t [a] ∪ ik⇩e⇩s⇩t A"
by (metis ik_append to_st_cons)
private lemma ik⇩e⇩s⇩t_append_subst:
"ik⇩e⇩s⇩t (A@B ⋅⇩e⇩s⇩t θ) = ik⇩e⇩s⇩t (A ⋅⇩e⇩s⇩t θ) ∪ ik⇩e⇩s⇩t (B ⋅⇩e⇩s⇩t θ)"
"ik⇩e⇩s⇩t (A@B) ⋅⇩s⇩e⇩t θ = (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t θ) ∪ (ik⇩e⇩s⇩t B ⋅⇩s⇩e⇩t θ)"
by (metis ik⇩e⇩s⇩t_append extstrand_subst_hom(1), simp add: image_Un to_st_append)
private lemma assignment_rhs⇩e⇩s⇩t_append_subst:
"assignment_rhs⇩e⇩s⇩t (A@B ⋅⇩e⇩s⇩t θ) = assignment_rhs⇩e⇩s⇩t (A ⋅⇩e⇩s⇩t θ) ∪ assignment_rhs⇩e⇩s⇩t (B ⋅⇩e⇩s⇩t θ)"
"assignment_rhs⇩e⇩s⇩t (A@B) ⋅⇩s⇩e⇩t θ = (assignment_rhs⇩e⇩s⇩t A ⋅⇩s⇩e⇩t θ) ∪ (assignment_rhs⇩e⇩s⇩t B ⋅⇩s⇩e⇩t θ)"
by (metis assignment_rhs⇩e⇩s⇩t_append extstrand_subst_hom(1), use assignment_rhs⇩e⇩s⇩t_append in blast)
private lemma ik⇩e⇩s⇩t_cons_subst:
"ik⇩e⇩s⇩t (a#A ⋅⇩e⇩s⇩t θ) = ik⇩e⇩s⇩t ([a ⋅⇩e⇩s⇩t⇩p θ]) ∪ ik⇩e⇩s⇩t (A ⋅⇩e⇩s⇩t θ)"
"ik⇩e⇩s⇩t (a#A) ⋅⇩s⇩e⇩t θ = (ik⇩e⇩s⇩t [a] ⋅⇩s⇩e⇩t θ) ∪ (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t θ)"
by (metis ik⇩e⇩s⇩t_cons extstrand_subst_hom(2), metis image_Un ik⇩e⇩s⇩t_cons)
private lemma decomp_rm⇩e⇩s⇩t_append: "decomp_rm⇩e⇩s⇩t (S@S') = (decomp_rm⇩e⇩s⇩t S)@(decomp_rm⇩e⇩s⇩t S')"
by (induct S rule: decomp_rm⇩e⇩s⇩t.induct) auto
private lemma decomp_rm⇩e⇩s⇩t_single[simp]:
"decomp_rm⇩e⇩s⇩t [Step (send⟨t⟩⇩s⇩t)] = [Step (send⟨t⟩⇩s⇩t)]"
"decomp_rm⇩e⇩s⇩t [Step (receive⟨t⟩⇩s⇩t)] = [Step (receive⟨t⟩⇩s⇩t)]"
"decomp_rm⇩e⇩s⇩t [Decomp t] = []"
by auto
private lemma decomp_rm⇩e⇩s⇩t_ik_subset: "ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t S) ⊆ ik⇩e⇩s⇩t S"
proof (induction S rule: decomp_rm⇩e⇩s⇩t.induct)
case (3 x S) thus ?case by (cases x) auto
qed auto
private lemma decomps⇩e⇩s⇩t_ik_subset: "D ∈ decomps⇩e⇩s⇩t M N ℐ ⟹ ik⇩e⇩s⇩t D ⊆ subterms⇩s⇩e⇩t (M ∪ N)"
proof (induction D rule: decomps⇩e⇩s⇩t.induct)
case (Decomp D f T K M')
have "ik⇩s⇩t (decomp (Fun f T)) ⊆ subterms (Fun f T)"
"ik⇩s⇩t (decomp (Fun f T)) = ik⇩e⇩s⇩t [Decomp (Fun f T)]"
using decomp_ik[OF Decomp.hyps(3)] Ana_subterm[OF Decomp.hyps(3)]
by auto
hence "ik⇩s⇩t (to_st [Decomp (Fun f T)]) ⊆ subterms⇩s⇩e⇩t (M ∪ N)"
using in_subterms_subset_Union[OF Decomp.hyps(2)]
by blast
thus ?case using ik⇩e⇩s⇩t_append[of D "[Decomp (Fun f T)]"] using Decomp.IH by auto
qed simp
private lemma decomps⇩e⇩s⇩t_decomp_rm⇩e⇩s⇩t_empty: "D ∈ decomps⇩e⇩s⇩t M N ℐ ⟹ decomp_rm⇩e⇩s⇩t D = []"
by (induct D rule: decomps⇩e⇩s⇩t.induct) (auto simp add: decomp_rm⇩e⇩s⇩t_append)
private lemma decomps⇩e⇩s⇩t_append:
assumes "A ∈ decomps⇩e⇩s⇩t S N ℐ" "B ∈ decomps⇩e⇩s⇩t S N ℐ"
shows "A@B ∈ decomps⇩e⇩s⇩t S N ℐ"
using assms(2)
proof (induction B rule: decomps⇩e⇩s⇩t.induct)
case Nil show ?case using assms(1) by simp
next
case (Decomp B f X K T)
hence "S ∪ ik⇩e⇩s⇩t B ⋅⇩s⇩e⇩t ℐ ⊆ S ∪ ik⇩e⇩s⇩t (A@B) ⋅⇩s⇩e⇩t ℐ" using ik⇩e⇩s⇩t_append by auto
thus ?case
using decomps⇩e⇩s⇩t.Decomp[OF Decomp.IH(1) Decomp.hyps(2,3,4)]
ideduct_synth_mono[OF Decomp.hyps(5)]
ideduct_synth_mono[OF Decomp.hyps(6)]
by auto
qed
private lemma decomps⇩e⇩s⇩t_subterms:
assumes "A' ∈ decomps⇩e⇩s⇩t M N ℐ"
shows "subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A') ⊆ subterms⇩s⇩e⇩t (M ∪ N)"
using assms
proof (induction A' rule: decomps⇩e⇩s⇩t.induct)
case (Decomp D f X K T)
hence "Fun f X ∈ subterms⇩s⇩e⇩t (M ∪ N)" by auto
hence "subterms⇩s⇩e⇩t (set X) ⊆ subterms⇩s⇩e⇩t (M ∪ N)"
using in_subterms_subset_Union[of "Fun f X" "M ∪ N"] params_subterms_Union[of X f]
by blast
moreover have "ik⇩s⇩t (to_st [Decomp (Fun f X)]) = set T" using Decomp.hyps(3) decomp_ik by simp
hence "subterms⇩s⇩e⇩t (ik⇩s⇩t (to_st [Decomp (Fun f X)])) ⊆ subterms⇩s⇩e⇩t (set X)"
using Ana_fun_subterm[OF Decomp.hyps(3)] by auto
ultimately show ?case
using ik⇩e⇩s⇩t_append[of D "[Decomp (Fun f X)]"] Decomp.IH
by auto
qed simp
private lemma decomps⇩e⇩s⇩t_assignment_rhs_empty:
assumes "A' ∈ decomps⇩e⇩s⇩t M N ℐ"
shows "assignment_rhs⇩e⇩s⇩t A' = {}"
using assms
by (induction A' rule: decomps⇩e⇩s⇩t.induct)
(simp_all add: decomp_assignment_rhs_empty assignment_rhs⇩e⇩s⇩t_append)
private lemma decomps⇩e⇩s⇩t_finite_ik_append:
assumes "finite M" "M ⊆ decomps⇩e⇩s⇩t A N ℐ"
shows "∃D ∈ decomps⇩e⇩s⇩t A N ℐ. ik⇩e⇩s⇩t D = (⋃m ∈ M. ik⇩e⇩s⇩t m)"
using assms
proof (induction M rule: finite_induct)
case empty
moreover have "[] ∈ decomps⇩e⇩s⇩t A N ℐ" "ik⇩s⇩t (to_st []) = {}" using decomps⇩e⇩s⇩t.Nil by auto
ultimately show ?case by blast
next
case (insert m M)
then obtain D where "D ∈ decomps⇩e⇩s⇩t A N ℐ" "ik⇩e⇩s⇩t D = (⋃m∈M. ik⇩s⇩t (to_st m))" by moura
moreover have "m ∈ decomps⇩e⇩s⇩t A N ℐ" using insert.prems(1) by blast
ultimately show ?case using decomps⇩e⇩s⇩t_append[of D A N ℐ m] ik⇩e⇩s⇩t_append[of D m] by blast
qed
private lemma decomp_snd_exists[simp]: "∃D. decomp t = send⟨t⟩⇩s⇩t#D"
by (metis (mono_tags, lifting) decomp_def prod.case surj_pair)
private lemma decomp_nonnil[simp]: "decomp t ≠ []"
using decomp_snd_exists[of t] by fastforce
private lemma to_st_nil_inv[dest]: "to_st A = [] ⟹ A = []"
by (induct A rule: to_st.induct) auto
private lemma well_analyzedD:
assumes "well_analyzed A" "Decomp t ∈ set A"
shows "∃f T. t = Fun f T"
using assms
proof (induction A rule: well_analyzed.induct)
case (Decomp A t')
hence "∃f T. t' = Fun f T" by (cases t') auto
moreover have "Decomp t ∈ set A ∨ t = t'" using Decomp by auto
ultimately show ?case using Decomp.IH by auto
qed auto
private lemma well_analyzed_inv:
assumes "well_analyzed (A@[Decomp t])"
shows "t ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A) - (Var ` 𝒱)"
using assms well_analyzed.cases[of "A@[Decomp t]"] by fastforce
private lemma well_analyzed_split_left_single: "well_analyzed (A@[a]) ⟹ well_analyzed A"
by (induction "A@[a]" rule: well_analyzed.induct) auto
private lemma well_analyzed_split_left: "well_analyzed (A@B) ⟹ well_analyzed A"
proof (induction B rule: List.rev_induct)
case (snoc b B) thus ?case using well_analyzed_split_left_single[of "A@B" b] by simp
qed simp
private lemma well_analyzed_append:
assumes "well_analyzed A" "well_analyzed B"
shows "well_analyzed (A@B)"
using assms(2,1)
proof (induction B rule: well_analyzed.induct)
case (Step B x) show ?case using well_analyzed.Step[OF Step.IH[OF Step.prems]] by simp
next
case (Decomp B t) thus ?case
using well_analyzed.Decomp[OF Decomp.IH[OF Decomp.prems]] ik⇩e⇩s⇩t_append assignment_rhs⇩e⇩s⇩t_append
by auto
qed simp_all
private lemma well_analyzed_singleton:
"well_analyzed [Step (send⟨t⟩⇩s⇩t)]" "well_analyzed [Step (receive⟨t⟩⇩s⇩t)]"
"well_analyzed [Step (⟨a: t ≐ t'⟩⇩s⇩t)]" "well_analyzed [Step (∀X⟨∨≠: F⟩⇩s⇩t)]"
"¬well_analyzed [Decomp t]"
proof -
show "well_analyzed [Step (send⟨t⟩⇩s⇩t)]" "well_analyzed [Step (receive⟨t⟩⇩s⇩t)]"
"well_analyzed [Step (⟨a: t ≐ t'⟩⇩s⇩t)]" "well_analyzed [Step (∀X⟨∨≠: F⟩⇩s⇩t)]"
using well_analyzed.Step[OF well_analyzed.Nil]
by simp_all
show "¬well_analyzed [Decomp t]" using well_analyzed.cases[of "[Decomp t]"] by auto
qed
private lemma well_analyzed_decomp_rm⇩e⇩s⇩t_fv: "well_analyzed A ⟹ fv⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) = fv⇩e⇩s⇩t A"
proof
assume "well_analyzed A" thus "fv⇩e⇩s⇩t A ⊆ fv⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A)"
proof (induction A rule: well_analyzed.induct)
case Decomp thus ?case using ik_assignment_rhs_decomp_fv decomp_rm⇩e⇩s⇩t_append by auto
next
case (Step A x)
have "fv⇩e⇩s⇩t (A@[Step x]) = fv⇩e⇩s⇩t A ∪ fv⇩s⇩t⇩p x"
"fv⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t (A@[Step x])) = fv⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ fv⇩s⇩t⇩p x"
using fv⇩e⇩s⇩t_append decomp_rm⇩e⇩s⇩t_append by auto
thus ?case using Step by auto
qed simp
qed (rule fv_decomp_rm)
private lemma sem⇩e⇩s⇩t_d_split_left: assumes "sem⇩e⇩s⇩t_d M⇩0 ℐ (𝒜@𝒜')" shows "sem⇩e⇩s⇩t_d M⇩0 ℐ 𝒜"
using assms sem⇩e⇩s⇩t_d.cases by (induction 𝒜' rule: List.rev_induct) fastforce+
private lemma sem⇩e⇩s⇩t_d_eq_sem_st: "sem⇩e⇩s⇩t_d M⇩0 ℐ 𝒜 = ⟦M⇩0; to_st 𝒜⟧⇩d' ℐ"
proof
show "⟦M⇩0; to_st 𝒜⟧⇩d' ℐ ⟹ sem⇩e⇩s⇩t_d M⇩0 ℐ 𝒜"
proof (induction 𝒜 arbitrary: M⇩0 rule: List.rev_induct)
case Nil show ?case using to_st_nil_inv by simp
next
case (snoc a 𝒜)
hence IH: "sem⇩e⇩s⇩t_d M⇩0 ℐ 𝒜" and *: "⟦ik⇩e⇩s⇩t 𝒜 ∪ M⇩0; to_st [a]⟧⇩d' ℐ"
using to_st_append by (auto simp add: sup.commute)
thus ?case using snoc
proof (cases a)
case (Step b) thus ?thesis
proof (cases b)
case (Send t) thus ?thesis using sem⇩e⇩s⇩t_d.Send[OF IH] * Step by auto
next
case (Receive t) thus ?thesis using sem⇩e⇩s⇩t_d.Receive[OF IH] Step by auto
next
case (Equality a t t') thus ?thesis using sem⇩e⇩s⇩t_d.Equality[OF IH] * Step by auto
next
case (Inequality X F) thus ?thesis using sem⇩e⇩s⇩t_d.Inequality[OF IH] * Step by auto
qed
next
case (Decomp t)
obtain K M where Ana: "Ana t = (K,M)" by moura
have "to_st [a] = decomp t" using Decomp by auto
hence "to_st [a] = send⟨t⟩⇩s⇩t#map Send K@map Receive M"
using Ana unfolding decomp_def by auto
hence **: "ik⇩e⇩s⇩t 𝒜 ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ" and "⟦ik⇩e⇩s⇩t 𝒜 ∪ M⇩0; map Send K⟧⇩d' ℐ"
using * by auto
hence "⋀k. k ∈ set K ⟹ ik⇩e⇩s⇩t 𝒜 ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ k ⋅ ℐ"
using *
by (metis (full_types) strand_sem_d.simps(2) strand_sem_eq_defs(2) strand_sem_Send_split(2))
thus ?thesis using Decomp sem⇩e⇩s⇩t_d.Decompose[OF IH ** Ana] by metis
qed
qed
show "sem⇩e⇩s⇩t_d M⇩0 ℐ 𝒜 ⟹ ⟦M⇩0; to_st 𝒜⟧⇩d' ℐ"
proof (induction rule: sem⇩e⇩s⇩t_d.induct)
case Nil thus ?case by simp
next
case (Send M⇩0 ℐ 𝒜 t) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[send⟨t⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (send⟨t⟩⇩s⇩t)]"]
by (simp add: sup.commute)
next
case (Receive M⇩0 ℐ 𝒜 t) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[receive⟨t⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (receive⟨t⟩⇩s⇩t)]"]
by (simp add: sup.commute)
next
case (Equality M⇩0 ℐ 𝒜 t t' a) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[⟨a: t ≐ t'⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (⟨a: t ≐ t'⟩⇩s⇩t)]"]
by (simp add: sup.commute)
next
case (Inequality M⇩0 ℐ 𝒜 X F) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[∀X⟨∨≠: F⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (∀X⟨∨≠: F⟩⇩s⇩t)]"]
by (simp add: sup.commute)
next
case (Decompose M⇩0 ℐ 𝒜 t K M)
have "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); decomp t⟧⇩d' ℐ"
proof -
have "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); [send⟨t⟩⇩s⇩t]⟧⇩d' ℐ"
using Decompose.hyps(2) by (auto simp add: sup.commute)
moreover have "⋀k. k ∈ set K ⟹ M⇩0 ∪ ik⇩s⇩t (to_st 𝒜) ⋅⇩s⇩e⇩t ℐ ⊢ k ⋅ ℐ"
using Decompose by (metis sup.commute)
hence "⋀k. k ∈ set K ⟹ ⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); [Send k]⟧⇩d' ℐ" by auto
hence "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); map Send K⟧⇩d' ℐ"
using strand_sem_Send_map(2)[of K, of "M⇩0 ∪ ik⇩s⇩t (to_st 𝒜) ⋅⇩s⇩e⇩t ℐ" ℐ] strand_sem_eq_defs(2)
by auto
moreover have "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); map Receive M⟧⇩d' ℐ"
by (metis strand_sem_Receive_map(2) strand_sem_eq_defs(2))
ultimately have
"⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); send⟨t⟩⇩s⇩t#map Send K@map Receive M⟧⇩d' ℐ"
by auto
thus ?thesis using Decompose.hyps(3) unfolding decomp_def by auto
qed
hence "⟦M⇩0; to_st 𝒜@decomp t⟧⇩d' ℐ"
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "decomp t"] Decompose.IH
by simp
thus ?case using to_st_append[of 𝒜 "[Decomp t]"] by simp
qed
qed
private lemma sem⇩e⇩s⇩t_c_eq_sem_st: "sem⇩e⇩s⇩t_c M⇩0 ℐ 𝒜 = ⟦M⇩0; to_st 𝒜⟧⇩c' ℐ"
proof
show "⟦M⇩0; to_st 𝒜⟧⇩c' ℐ ⟹ sem⇩e⇩s⇩t_c M⇩0 ℐ 𝒜"
proof (induction 𝒜 arbitrary: M⇩0 rule: List.rev_induct)
case Nil show ?case using to_st_nil_inv by simp
next
case (snoc a 𝒜)
hence IH: "sem⇩e⇩s⇩t_c M⇩0 ℐ 𝒜" and *: "⟦ik⇩e⇩s⇩t 𝒜 ∪ M⇩0; to_st [a]⟧⇩c' ℐ"
using to_st_append
by (auto simp add: sup.commute)
thus ?case using snoc
proof (cases a)
case (Step b) thus ?thesis
proof (cases b)
case (Send t) thus ?thesis using sem⇩e⇩s⇩t_c.Send[OF IH] * Step by auto
next
case (Receive t) thus ?thesis using sem⇩e⇩s⇩t_c.Receive[OF IH] Step by auto
next
case (Equality t) thus ?thesis using sem⇩e⇩s⇩t_c.Equality[OF IH] * Step by auto
next
case (Inequality t) thus ?thesis using sem⇩e⇩s⇩t_c.Inequality[OF IH] * Step by auto
qed
next
case (Decomp t)
obtain K M where Ana: "Ana t = (K,M)" by moura
have "to_st [a] = decomp t" using Decomp by auto
hence "to_st [a] = send⟨t⟩⇩s⇩t#map Send K@map Receive M"
using Ana unfolding decomp_def by auto
hence **: "ik⇩e⇩s⇩t 𝒜 ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ" and "⟦ik⇩e⇩s⇩t 𝒜 ∪ M⇩0; map Send K⟧⇩c' ℐ"
using * by auto
hence "⋀k. k ∈ set K ⟹ ik⇩e⇩s⇩t 𝒜 ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ"
using * strand_sem_Send_split(1) strand_sem_eq_defs(1)
by auto
thus ?thesis using Decomp sem⇩e⇩s⇩t_c.Decompose[OF IH ** Ana] by metis
qed
qed
show "sem⇩e⇩s⇩t_c M⇩0 ℐ 𝒜 ⟹ ⟦M⇩0; to_st 𝒜⟧⇩c' ℐ"
proof (induction rule: sem⇩e⇩s⇩t_c.induct)
case Nil thus ?case by simp
next
case (Send M⇩0 ℐ 𝒜 t) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[send⟨t⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (send⟨t⟩⇩s⇩t)]"]
by (simp add: sup.commute)
next
case (Receive M⇩0 ℐ 𝒜 t) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[receive⟨t⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (receive⟨t⟩⇩s⇩t)]"]
by (simp add: sup.commute)
next
case (Equality M⇩0 ℐ 𝒜 t t' a) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[⟨a: t ≐ t'⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (⟨a: t ≐ t'⟩⇩s⇩t)]"]
by (simp add: sup.commute)
next
case (Inequality M⇩0 ℐ 𝒜 X F) thus ?case
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "[∀X⟨∨≠: F⟩⇩s⇩t]"]
to_st_append[of 𝒜 "[Step (∀X⟨∨≠: F⟩⇩s⇩t)]"]
by (auto simp add: sup.commute)
next
case (Decompose M⇩0 ℐ 𝒜 t K M)
have "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); decomp t⟧⇩c' ℐ"
proof -
have "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); [send⟨t⟩⇩s⇩t]⟧⇩c' ℐ"
using Decompose.hyps(2) by (auto simp add: sup.commute)
moreover have "⋀k. k ∈ set K ⟹ M⇩0 ∪ ik⇩s⇩t (to_st 𝒜) ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ"
using Decompose by (metis sup.commute)
hence "⋀k. k ∈ set K ⟹ ⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); [Send k]⟧⇩c' ℐ" by auto
hence "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); map Send K⟧⇩c' ℐ"
using strand_sem_Send_map(1)[of K, of "M⇩0 ∪ ik⇩s⇩t (to_st 𝒜) ⋅⇩s⇩e⇩t ℐ" ℐ]
strand_sem_eq_defs(1)
by auto
moreover have "⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); map Receive M⟧⇩c' ℐ"
by (metis strand_sem_Receive_map(1) strand_sem_eq_defs(1))
ultimately have
"⟦M⇩0 ∪ ik⇩s⇩t (to_st 𝒜); send⟨t⟩⇩s⇩t#map Send K@map Receive M⟧⇩c' ℐ"
by auto
thus ?thesis using Decompose.hyps(3) unfolding decomp_def by auto
qed
hence "⟦M⇩0; to_st 𝒜@decomp t⟧⇩c' ℐ"
using strand_sem_append'[of M⇩0 "to_st 𝒜" ℐ "decomp t"] Decompose.IH
by simp
thus ?case using to_st_append[of 𝒜 "[Decomp t]"] by simp
qed
qed
private lemma sem⇩e⇩s⇩t_c_decomp_rm⇩e⇩s⇩t_deduct_aux:
assumes "sem⇩e⇩s⇩t_c M⇩0 ℐ A" "t ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ" "t ∉ ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⋅⇩s⇩e⇩t ℐ"
shows "ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ t"
using assms
proof (induction M⇩0 ℐ A arbitrary: t rule: sem⇩e⇩s⇩t_c.induct)
case (Send M⇩0 ℐ A t') thus ?case using decomp_rm⇩e⇩s⇩t_append ik⇩e⇩s⇩t_append by auto
next
case (Receive M⇩0 ℐ A t')
hence "t ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ" "t ∉ ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⋅⇩s⇩e⇩t ℐ"
using decomp_rm⇩e⇩s⇩t_append ik⇩e⇩s⇩t_append by auto
hence IH: "ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ t" using Receive.IH by auto
show ?case using ideduct_mono[OF IH] decomp_rm⇩e⇩s⇩t_append ik⇩e⇩s⇩t_append by auto
next
case (Equality M⇩0 ℐ A t') thus ?case using decomp_rm⇩e⇩s⇩t_append ik⇩e⇩s⇩t_append by auto
next
case (Inequality M⇩0 ℐ A t') thus ?case using decomp_rm⇩e⇩s⇩t_append ik⇩e⇩s⇩t_append by auto
next
case (Decompose M⇩0 ℐ A t' K M t)
have *: "ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ t' ⋅ ℐ" using Decompose.hyps(2)
proof (induction rule: intruder_synth_induct)
case (AxiomC t'')
moreover {
assume "t'' ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ" "t'' ∉ ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⋅⇩s⇩e⇩t ℐ"
hence ?case using Decompose.IH by auto
}
ultimately show ?case by force
qed simp
{ fix k assume "k ∈ set K"
hence "ik⇩e⇩s⇩t A ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ" using Decompose.hyps by auto
hence "ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ k ⋅ ℐ"
proof (induction rule: intruder_synth_induct)
case (AxiomC t'')
moreover {
assume "t'' ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ" "t'' ∉ ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⋅⇩s⇩e⇩t ℐ"
hence ?case using Decompose.IH by auto
}
ultimately show ?case by force
qed simp
}
hence **: "⋀k. k ∈ set (K ⋅⇩l⇩i⇩s⇩t ℐ) ⟹ ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ k" by auto
show ?case
proof (cases "t ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ")
case True thus ?thesis using Decompose.IH Decompose.prems(2) decomp_rm⇩e⇩s⇩t_append by auto
next
case False
hence "t ∈ ik⇩s⇩t (decomp t') ⋅⇩s⇩e⇩t ℐ" using Decompose.prems(1) ik⇩e⇩s⇩t_append by auto
hence ***: "t ∈ set (M ⋅⇩l⇩i⇩s⇩t ℐ)" using Decompose.hyps(3) decomp_ik by auto
hence "M ≠ []" by auto
hence ****: "Ana (t' ⋅ ℐ) = (K ⋅⇩l⇩i⇩s⇩t ℐ, M ⋅⇩l⇩i⇩s⇩t ℐ)" using Ana_subst[OF Decompose.hyps(3)] by auto
have "ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ t" by (rule intruder_deduct.Decompose[OF * **** ** ***])
thus ?thesis using ideduct_mono decomp_rm⇩e⇩s⇩t_append by auto
qed
qed simp
private lemma sem⇩e⇩s⇩t_c_decomp_rm⇩e⇩s⇩t_deduct:
assumes "sem⇩e⇩s⇩t_c M⇩0 ℐ A" "ik⇩e⇩s⇩t A ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢⇩c t"
shows "ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ∪ M⇩0 ⋅⇩s⇩e⇩t ℐ ⊢ t"
using assms(2)
proof (induction t rule: intruder_synth_induct)
case (AxiomC t)
hence "t ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ ∨ t ∈ M⇩0 ⋅⇩s⇩e⇩t ℐ" by auto
moreover {
assume "t ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ" "t ∈ ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⋅⇩s⇩e⇩t ℐ"
hence ?case using ideduct_mono[OF intruder_deduct.Axiom] by auto
}
moreover {
assume "t ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ" "t ∉ ik⇩e⇩s⇩t (decomp_rm⇩e⇩s⇩t A) ⋅⇩s⇩e⇩t ℐ"
hence ?case using sem⇩e⇩s⇩t_c_decomp_rm⇩e⇩s⇩t_deduct_aux[OF assms(1)] by auto
}
ultimately show ?case by auto
qed simp
private lemma sem⇩e⇩s⇩t_d_decomp_rm⇩e⇩s⇩t_if_sem⇩e⇩s⇩t_c: "sem⇩e⇩s⇩t_c M⇩0 ℐ A ⟹ sem⇩e⇩s⇩t_d M⇩0 ℐ (decomp_rm⇩e⇩s⇩t A)"
proof (induction M⇩0 ℐ A rule: sem⇩e⇩s⇩t_c.induct)
case (Send M⇩0 ℐ A t)
thus ?case using decomp_rm⇩e⇩s⇩t_append sem⇩e⇩s⇩t_d.Send[OF Send.IH] sem⇩e⇩s⇩t_c_decomp_rm⇩e⇩s⇩t_deduct by auto
next
case (Receive t) thus ?case using decomp_rm⇩e⇩s⇩t_append sem⇩e⇩s⇩t_d.Receive by auto
next
case (Equality M⇩0 ℐ A t)
thus ?case
using decomp_rm⇩e⇩s⇩t_append sem⇩e⇩s⇩t_d.Equality[OF Equality.IH] sem⇩e⇩s⇩t_c_decomp_rm⇩e⇩s⇩t_deduct
by auto
next
case (Inequality M⇩0 ℐ A t)
thus ?case
using decomp_rm⇩e⇩s⇩t_append sem⇩e⇩s⇩t_d.Inequality[OF Inequality.IH] sem⇩e⇩s⇩t_c_decomp_rm⇩e⇩s⇩t_deduct
by auto
next
case Decompose thus ?case using decomp_rm⇩e⇩s⇩t_append by auto
qed auto
private lemma sem⇩e⇩s⇩t_c_decomps⇩e⇩s⇩t_append:
assumes "sem⇩e⇩s⇩t_c {} ℐ A" "D ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t 𝒜) ℐ"
shows "sem⇩e⇩s⇩t_c {} ℐ (A@D)"
using assms(2,1)
proof (induction D rule: decomps⇩e⇩s⇩t.induct)
case (Decomp D f T K M)
hence *: "sem⇩e⇩s⇩t_c {} ℐ (A @ D)" "ik⇩e⇩s⇩t (A@D) ∪ {} ⋅⇩s⇩e⇩t ℐ ⊢⇩c Fun f T ⋅ ℐ"
"⋀k. k ∈ set K ⟹ ik⇩e⇩s⇩t (A @ D) ∪ {} ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ"
using ik⇩e⇩s⇩t_append by auto
show ?case using sem⇩e⇩s⇩t_c.Decompose[OF *(1,2) Decomp.hyps(3) *(3)] by simp
qed auto
private lemma decomps⇩e⇩s⇩t_preserves_wf:
assumes "D ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t A) ℐ" "wf⇩e⇩s⇩t V A"
shows "wf⇩e⇩s⇩t V (A@D)"
using assms
proof (induction D rule: decomps⇩e⇩s⇩t.induct)
case (Decomp D f T K M)
have "wfrestrictedvars⇩s⇩t (decomp (Fun f T)) ⊆ fv⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
using decomp_vars fv_subset_subterms[OF Decomp.hyps(2)] by fast
hence "wfrestrictedvars⇩s⇩t (decomp (Fun f T)) ⊆ wfrestrictedvars⇩e⇩s⇩t A"
using ik⇩s⇩t_assignment_rhs⇩s⇩t_wfrestrictedvars_subset[of "to_st A"] by blast
hence "wfrestrictedvars⇩s⇩t (decomp (Fun f T)) ⊆ wfrestrictedvars⇩s⇩t (to_st (A@D)) ∪ V"
using to_st_append[of A D] strand_vars_split(2)[of "to_st A" "to_st D"]
by (metis le_supI1)
thus ?case
using wf_append_suffix[OF Decomp.IH[OF Decomp.prems], of "decomp (Fun f T)"]
to_st_append[of "A@D" "[Decomp (Fun f T)]"]
by auto
qed auto
private lemma decomps⇩e⇩s⇩t_preserves_model_c:
assumes "D ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t A) ℐ" "sem⇩e⇩s⇩t_c M⇩0 ℐ A"
shows "sem⇩e⇩s⇩t_c M⇩0 ℐ (A@D)"
using assms
proof (induction D rule: decomps⇩e⇩s⇩t.induct)
case (Decomp D f T K M) show ?case
using sem⇩e⇩s⇩t_c.Decompose[OF Decomp.IH[OF Decomp.prems] _ Decomp.hyps(3)]
Decomp.hyps(5,6) ideduct_synth_mono ik⇩e⇩s⇩t_append
by (metis (mono_tags, lifting) List.append_assoc image_Un sup_ge1)
qed auto
private lemma decomps⇩e⇩s⇩t_exist_aux:
assumes "D ∈ decomps⇩e⇩s⇩t M N ℐ" "M ∪ ik⇩e⇩s⇩t D ⊢ t" "¬(M ∪ (ik⇩e⇩s⇩t D) ⊢⇩c t)"
obtains D' where
"D@D' ∈ decomps⇩e⇩s⇩t M N ℐ" "M ∪ ik⇩e⇩s⇩t (D@D') ⊢⇩c t" "M ∪ ik⇩e⇩s⇩t D ⊂ M ∪ ik⇩e⇩s⇩t (D@D')"
proof -
have "∃D' ∈ decomps⇩e⇩s⇩t M N ℐ. M ∪ ik⇩e⇩s⇩t D' ⊢⇩c t" using assms(2)
proof (induction t rule: intruder_deduct_induct)
case (Compose X f)
from Compose.IH have "∃D ∈ decomps⇩e⇩s⇩t M N ℐ. ∀x ∈ set X. M ∪ ik⇩e⇩s⇩t D ⊢⇩c x"
proof (induction X)
case (Cons t X)
then obtain D' D'' where
D': "D' ∈ decomps⇩e⇩s⇩t M N ℐ" "M ∪ ik⇩e⇩s⇩t D' ⊢⇩c t" and
D'': "D'' ∈ decomps⇩e⇩s⇩t M N ℐ" "∀x ∈ set X. M ∪ ik⇩e⇩s⇩t D'' ⊢⇩c x"
by moura
hence "M ∪ ik⇩e⇩s⇩t (D'@D'') ⊢⇩c t" "∀x ∈ set X. M ∪ ik⇩e⇩s⇩t (D'@D'') ⊢⇩c x"
by (auto intro: ideduct_synth_mono simp add: ik⇩e⇩s⇩t_append)
thus ?case using decomps⇩e⇩s⇩t_append[OF D'(1) D''(1)] by (metis set_ConsD)
qed (auto intro: decomps⇩e⇩s⇩t.Nil)
thus ?case using intruder_synth.ComposeC[OF Compose.hyps(1,2)] by metis
next
case (Decompose t K T t⇩i)
have "∃D ∈ decomps⇩e⇩s⇩t M N ℐ. ∀k ∈ set K. M ∪ ik⇩e⇩s⇩t D ⊢⇩c k" using Decompose.IH
proof (induction K)
case (Cons t X)
then obtain D' D'' where
D': "D' ∈ decomps⇩e⇩s⇩t M N ℐ" "M ∪ ik⇩e⇩s⇩t D' ⊢⇩c t" and
D'': "D'' ∈ decomps⇩e⇩s⇩t M N ℐ" "∀x ∈ set X. M ∪ ik⇩e⇩s⇩t D'' ⊢⇩c x"
using assms(1) by moura
hence "M ∪ ik⇩e⇩s⇩t (D'@D'') ⊢⇩c t" "∀x ∈ set X. M ∪ ik⇩e⇩s⇩t (D'@D'') ⊢⇩c x"
by (auto intro: ideduct_synth_mono simp add: ik⇩e⇩s⇩t_append)
thus ?case using decomps⇩e⇩s⇩t_append[OF D'(1) D''(1)] by auto
qed auto
then obtain D' where D': "D' ∈ decomps⇩e⇩s⇩t M N ℐ" "⋀k. k ∈ set K ⟹ M ∪ ik⇩e⇩s⇩t D' ⊢⇩c k" by metis
obtain D'' where D'': "D'' ∈ decomps⇩e⇩s⇩t M N ℐ" "M ∪ ik⇩e⇩s⇩t D'' ⊢⇩c t" by (metis Decompose.IH(1))
obtain f X where fX: "t = Fun f X" "t⇩i ∈ set X"
using Decompose.hyps(2,4) by (cases t) (auto dest: Ana_fun_subterm)
from decomps⇩e⇩s⇩t_append[OF D'(1) D''(1)] D'(2) D''(2) have *:
"D'@D'' ∈ decomps⇩e⇩s⇩t M N ℐ" "⋀k. k ∈ set K ⟹ M ∪ ik⇩e⇩s⇩t (D'@D'') ⊢⇩c k"
"M ∪ ik⇩e⇩s⇩t (D'@D'') ⊢⇩c t"
by (auto intro: ideduct_synth_mono simp add: ik⇩e⇩s⇩t_append)
hence **: "⋀k. k ∈ set K ⟹ M ∪ ik⇩e⇩s⇩t (D'@D'') ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ"
using ideduct_synth_subst by auto
have "t⇩i ∈ ik⇩s⇩t (decomp t)" using Decompose.hyps(2,4) ik_rcv_map unfolding decomp_def by auto
with *(3) fX(1) Decompose.hyps(2) show ?case
proof (induction t rule: intruder_synth_induct)
case (AxiomC t)
hence t_in_subterms: "t ∈ subterms⇩s⇩e⇩t (M ∪ N)"
using decomps⇩e⇩s⇩t_ik_subset[OF *(1)] subset_subterms_Union
by auto
have "M ∪ ik⇩e⇩s⇩t (D'@D'') ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ"
using ideduct_synth_subst[OF intruder_synth.AxiomC[OF AxiomC.hyps(1)]] by metis
moreover have "T ≠ []" using decomp_ik[OF ‹Ana t = (K,T)›] ‹t⇩i ∈ ik⇩s⇩t (decomp t)› by auto
ultimately have "D'@D''@[Decomp (Fun f X)] ∈ decomps⇩e⇩s⇩t M N ℐ"
using AxiomC decomps⇩e⇩s⇩t.Decomp[OF *(1) _ _ _ _ **] subset_subterms_Union t_in_subterms
by (simp add: subset_eq)
moreover have "decomp t = to_st [Decomp (Fun f X)]" using AxiomC.prems(1,2) by auto
ultimately show ?case
by (metis AxiomC.prems(3) UnCI intruder_synth.AxiomC ik⇩e⇩s⇩t_append to_st_append)
qed (auto intro!: fX(2) *(1))
qed (fastforce intro: intruder_synth.AxiomC assms(1))
hence "∃D' ∈ decomps⇩e⇩s⇩t M N ℐ. M ∪ ik⇩e⇩s⇩t (D@D') ⊢⇩c t"
by (auto intro: ideduct_synth_mono simp add: ik⇩e⇩s⇩t_append)
thus thesis using that[OF decomps⇩e⇩s⇩t_append[OF assms(1)]] assms ik⇩e⇩s⇩t_append by moura
qed
private lemma decomps⇩e⇩s⇩t_ik_max_exist:
assumes "finite A" "finite N"
shows "∃D ∈ decomps⇩e⇩s⇩t A N ℐ. ∀D' ∈ decomps⇩e⇩s⇩t A N ℐ. ik⇩e⇩s⇩t D' ⊆ ik⇩e⇩s⇩t D"
proof -
let ?IK = "λM. ⋃D ∈ M. ik⇩e⇩s⇩t D"
have "?IK (decomps⇩e⇩s⇩t A N ℐ) ⊆ (⋃t ∈ A ∪ N. subterms t)" by (auto dest!: decomps⇩e⇩s⇩t_ik_subset)
hence "finite (?IK (decomps⇩e⇩s⇩t A N ℐ))"
using subterms_union_finite[OF assms(1)] subterms_union_finite[OF assms(2)] infinite_super
by auto
then obtain M where M: "finite M" "M ⊆ decomps⇩e⇩s⇩t A N ℐ" "?IK M = ?IK (decomps⇩e⇩s⇩t A N ℐ)"
using finite_subset_Union by moura
show ?thesis using decomps⇩e⇩s⇩t_finite_ik_append[OF M(1,2)] M(3) by auto
qed
private lemma decomps⇩e⇩s⇩t_exist:
assumes "finite A" "finite N"
shows "∃D ∈ decomps⇩e⇩s⇩t A N ℐ. ∀t. A ⊢ t ⟶ A ∪ ik⇩e⇩s⇩t D ⊢⇩c t"
proof (rule ccontr)
assume neg: "¬(∃D ∈ decomps⇩e⇩s⇩t A N ℐ. ∀t. A ⊢ t ⟶ A ∪ ik⇩e⇩s⇩t D ⊢⇩c t)"
obtain D where D: "D ∈ decomps⇩e⇩s⇩t A N ℐ" "∀D' ∈ decomps⇩e⇩s⇩t A N ℐ. ik⇩e⇩s⇩t D' ⊆ ik⇩e⇩s⇩t D"
using decomps⇩e⇩s⇩t_ik_max_exist[OF assms] by moura
then obtain t where t: "A ∪ ik⇩e⇩s⇩t D ⊢ t" "¬(A ∪ ik⇩e⇩s⇩t D ⊢⇩c t)"
using neg by (fastforce intro: ideduct_mono)
obtain D' where D':
"D@D' ∈ decomps⇩e⇩s⇩t A N ℐ" "A ∪ ik⇩e⇩s⇩t (D@D') ⊢⇩c t"
"A ∪ ik⇩e⇩s⇩t D ⊂ A ∪ ik⇩e⇩s⇩t (D@D')"
by (metis decomps⇩e⇩s⇩t_exist_aux t D(1))
hence "ik⇩e⇩s⇩t D ⊂ ik⇩e⇩s⇩t (D@D')" using ik⇩e⇩s⇩t_append by auto
moreover have "ik⇩e⇩s⇩t (D@D') ⊆ ik⇩e⇩s⇩t D" using D(2) D'(1) by auto
ultimately show False by simp
qed
private lemma decomps⇩e⇩s⇩t_exist_subst:
assumes "ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ"
and "sem⇩e⇩s⇩t_c {} ℐ A" "wf⇩e⇩s⇩t {} A" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and "Ana_invar_subst (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
and "well_analyzed A"
shows "∃D ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t A) ℐ. ik⇩e⇩s⇩t (A@D) ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ"
proof -
have ik_eq: "ik⇩e⇩s⇩t (A ⋅⇩e⇩s⇩t ℐ) = ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ" using assms(5,6)
proof (induction A rule: List.rev_induct)
case (snoc a A)
hence "Ana_invar_subst (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
using Ana_invar_subst_subset[OF snoc.prems(1)] ik⇩e⇩s⇩t_append assignment_rhs⇩e⇩s⇩t_append
unfolding Ana_invar_subst_def by simp
with snoc have IH:
"ik⇩e⇩s⇩t (A@[a] ⋅⇩e⇩s⇩t ℐ) = (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t ([a] ⋅⇩e⇩s⇩t ℐ)"
"ik⇩e⇩s⇩t (A@[a]) ⋅⇩s⇩e⇩t ℐ = (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t [a] ⋅⇩s⇩e⇩t ℐ)"
using well_analyzed_split_left[OF snoc.prems(2)]
by (auto simp add: to_st_append ik⇩e⇩s⇩t_append_subst)
have "ik⇩e⇩s⇩t [a ⋅⇩e⇩s⇩t⇩p ℐ] = ik⇩e⇩s⇩t [a] ⋅⇩s⇩e⇩t ℐ"
proof (cases a)
case (Step b) thus ?thesis by (cases b) auto
next
case (Decomp t)
then obtain f T where t: "t = Fun f T" using well_analyzedD[OF snoc.prems(2)] by force
obtain K M where Ana_t: "Ana (Fun f T) = (K,M)" by (metis surj_pair)
moreover have "Fun f T ∈ subterms⇩s⇩e⇩t ((ik⇩e⇩s⇩t (A@[a]) ∪ assignment_rhs⇩e⇩s⇩t (A@[a])))"
using t Decomp snoc.prems(2)
by (auto dest: well_analyzed_inv simp add: ik⇩e⇩s⇩t_append assignment_rhs⇩e⇩s⇩t_append)
hence "Ana (Fun f T ⋅ ℐ) = (K ⋅⇩l⇩i⇩s⇩t ℐ, M ⋅⇩l⇩i⇩s⇩t ℐ)"
using Ana_t snoc.prems(1)
unfolding Ana_invar_subst_def by blast
ultimately show ?thesis using Decomp t by (auto simp add: decomp_ik)
qed
thus ?case using IH unfolding subst_apply_extstrand_def by simp
qed simp
moreover have assignment_rhs_eq: "assignment_rhs⇩e⇩s⇩t (A ⋅⇩e⇩s⇩t ℐ) = assignment_rhs⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ"
using assms(5,6)
proof (induction A rule: List.rev_induct)
case (snoc a A)
hence "Ana_invar_subst (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
using Ana_invar_subst_subset[OF snoc.prems(1)] ik⇩e⇩s⇩t_append assignment_rhs⇩e⇩s⇩t_append
unfolding Ana_invar_subst_def by simp
hence "assignment_rhs⇩e⇩s⇩t (A ⋅⇩e⇩s⇩t ℐ) = assignment_rhs⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ"
using snoc.IH well_analyzed_split_left[OF snoc.prems(2)]
by simp
hence IH:
"assignment_rhs⇩e⇩s⇩t (A@[a] ⋅⇩e⇩s⇩t ℐ) = (assignment_rhs⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ assignment_rhs⇩e⇩s⇩t ([a] ⋅⇩e⇩s⇩t ℐ)"
"assignment_rhs⇩e⇩s⇩t (A@[a]) ⋅⇩s⇩e⇩t ℐ = (assignment_rhs⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (assignment_rhs⇩e⇩s⇩t [a] ⋅⇩s⇩e⇩t ℐ)"
by (metis assignment_rhs⇩e⇩s⇩t_append_subst(1), metis assignment_rhs⇩e⇩s⇩t_append_subst(2))
have "assignment_rhs⇩e⇩s⇩t [a ⋅⇩e⇩s⇩t⇩p ℐ] = assignment_rhs⇩e⇩s⇩t [a] ⋅⇩s⇩e⇩t ℐ"
proof (cases a)
case (Step b) thus ?thesis by (cases b) auto
next
case (Decomp t)
then obtain f T where t: "t = Fun f T" using well_analyzedD[OF snoc.prems(2)] by force
obtain K M where Ana_t: "Ana (Fun f T) = (K,M)" by (metis surj_pair)
moreover have "Fun f T ∈ subterms⇩s⇩e⇩t ((ik⇩e⇩s⇩t (A@[a]) ∪ assignment_rhs⇩e⇩s⇩t (A@[a])))"
using t Decomp snoc.prems(2)
by (auto dest: well_analyzed_inv simp add: ik⇩e⇩s⇩t_append assignment_rhs⇩e⇩s⇩t_append)
hence "Ana (Fun f T ⋅ ℐ) = (K ⋅⇩l⇩i⇩s⇩t ℐ, M ⋅⇩l⇩i⇩s⇩t ℐ)"
using Ana_t snoc.prems(1) unfolding Ana_invar_subst_def by blast
ultimately show ?thesis using Decomp t by (auto simp add: decomp_assignment_rhs_empty)
qed
thus ?case using IH unfolding subst_apply_extstrand_def by simp
qed simp
ultimately obtain D where D:
"D ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) (assignment_rhs⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) Var"
"(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D) ⊢⇩c t ⋅ ℐ"
using decomps⇩e⇩s⇩t_exist[OF ik⇩e⇩s⇩t_finite assignment_rhs⇩e⇩s⇩t_finite, of "A ⋅⇩e⇩s⇩t ℐ" "A ⋅⇩e⇩s⇩t ℐ"]
ik⇩e⇩s⇩t_append assignment_rhs⇩e⇩s⇩t_append assms(1)
by force
let ?P = "λD D'. ∀t. (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D) ⊢⇩c t ⟶ (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t"
have "∃D' ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t A) ℐ. ?P D D'" using D(1)
proof (induction D rule: decomps⇩e⇩s⇩t.induct)
case Nil
have "ik⇩e⇩s⇩t [] = ik⇩e⇩s⇩t [] ⋅⇩s⇩e⇩t ℐ" by auto
thus ?case by (metis decomps⇩e⇩s⇩t.Nil)
next
case (Decomp D f T K M)
obtain D' where D': "D' ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t A) ℐ" "?P D D'"
using Decomp.IH by auto
hence IH: "⋀k. k ∈ set K ⟹ (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c k"
"(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c Fun f T"
using Decomp.hyps(5,6) by auto
have D'_ik: "ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ ⊆ subterms⇩s⇩e⇩t ((ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)) ⋅⇩s⇩e⇩t ℐ"
"ik⇩e⇩s⇩t D' ⊆ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
using decomps⇩e⇩s⇩t_ik_subset[OF D'(1)] by (metis subst_all_mono, metis)
show ?case using IH(2,1) Decomp.hyps(2,3,4)
proof (induction "Fun f T" arbitrary: f T K M rule: intruder_synth_induct)
case (AxiomC f T)
then obtain s where s: "s ∈ ik⇩e⇩s⇩t A ∪ ik⇩e⇩s⇩t D'" "Fun f T = s ⋅ ℐ" using AxiomC.prems by blast
hence fT_s_in: "Fun f T ∈ (subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)) ⋅⇩s⇩e⇩t ℐ"
"s ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
using AxiomC D'_ik subset_subterms_Union[of "ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A"]
subst_all_mono[OF subset_subterms_Union, of ℐ]
by (metis (no_types) Un_iff image_eqI subset_Un_eq, metis (no_types) Un_iff subset_Un_eq)
obtain Ks Ms where Ana_s: "Ana s = (Ks,Ms)" by moura
have AD'_props: "wf⇩e⇩s⇩t {} (A@D')" "⟦{}; to_st (A@D')⟧⇩c ℐ"
using decomps⇩e⇩s⇩t_preserves_model_c[OF D'(1) assms(2)]
decomps⇩e⇩s⇩t_preserves_wf[OF D'(1) assms(3)]
sem⇩e⇩s⇩t_c_eq_sem_st strand_sem_eq_defs(1)
by auto
show ?case
proof (cases s)
case (Var x)
hence "Var x ∈ ik⇩e⇩s⇩t (A@D')" "ℐ x = Fun f T" using s ik⇩e⇩s⇩t_append by auto
show ?thesis
proof (cases "∀m ∈ set M. ik⇩e⇩s⇩t A ∪ ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ ⊢⇩c m")
case True
have *: "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t (D@[Decomp (Fun f T)]) = (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t D ∪ set M"
using decomp_ik[OF ‹Ana (Fun f T) = (K,M)›] ik⇩e⇩s⇩t_append[of D "[Decomp (Fun f T)]"]
by auto
{ fix t' assume "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t D ∪ set M ⊢⇩c t'"
hence "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t'"
proof (induction t' rule: intruder_synth_induct)
case (AxiomC t') thus ?case
proof
assume "t' ∈ set M"
moreover have "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) = ik⇩e⇩s⇩t A ∪ ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ" by auto
ultimately show ?case using True by auto
qed (metis D'(2) intruder_synth.AxiomC)
qed auto
}
thus ?thesis using D'(1) * by metis
next
case False
then obtain t⇩i where t⇩i: "t⇩i ∈ set T" "¬ik⇩e⇩s⇩t (A@D') ⋅⇩s⇩e⇩t ℐ ⊢⇩c t⇩i"
using Ana_fun_subterm[OF ‹Ana (Fun f T) = (K,M)›] by (auto simp add: ik⇩e⇩s⇩t_append)
obtain S where fS:
"Fun f S ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t (A@D')) ∨
Fun f S ∈ subterms⇩s⇩e⇩t (assignment_rhs⇩e⇩s⇩t (A@D'))"
"ℐ x = Fun f S ⋅ ℐ"
using strand_sem_wf_ik_or_assignment_rhs_fun_subterm[
OF AD'_props ‹Var x ∈ ik⇩e⇩s⇩t (A@D')› _ t⇩i ‹interpretation⇩s⇩u⇩b⇩s⇩t ℐ›]
‹ℐ x = Fun f T›
by moura
hence fS_in: "Fun f S ⋅ ℐ ∈ ik⇩e⇩s⇩t A ∪ ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ"
"Fun f S ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A)"
using imageI[OF s(1), of "λx. x ⋅ ℐ"] Var
ik⇩e⇩s⇩t_append[of A D'] assignment_rhs⇩e⇩s⇩t_append[of A D']
decomps⇩e⇩s⇩t_subterms[OF D'(1)] decomps⇩e⇩s⇩t_assignment_rhs_empty[OF D'(1)]
by auto
obtain KS MS where Ana_fS: "Ana (Fun f S) = (KS, MS)" by moura
hence "K = KS ⋅⇩l⇩i⇩s⇩t ℐ" "M = MS ⋅⇩l⇩i⇩s⇩t ℐ"
using Ana_invar_substD[OF assms(5) fS_in(2)]
s(2) fS(2) ‹s = Var x› ‹Ana (Fun f T) = (K,M)›
by simp_all
hence "MS ≠ []" using ‹M ≠ []› by simp
have "⋀k. k ∈ set KS ⟹ ik⇩e⇩s⇩t A ∪ ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ ⊢⇩c k ⋅ ℐ"
using AxiomC.prems(1) ‹K = KS ⋅⇩l⇩i⇩s⇩t ℐ› by (simp add: image_Un)
hence D'': "D'@[Decomp (Fun f S)] ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t A) ℐ"
using decomps⇩e⇩s⇩t.Decomp[OF D'(1) fS_in(2) Ana_fS ‹MS ≠ []›] AxiomC.prems(1)
intruder_synth.AxiomC[OF fS_in(1)]
by simp
moreover {
fix t' assume "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t (D@[Decomp (Fun f T)]) ⊢⇩c t'"
hence "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t (D'@[Decomp (Fun f S)]) ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t'"
proof (induction t' rule: intruder_synth_induct)
case (AxiomC t')
hence "t' ∈ (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t D ∨ t' ∈ ik⇩e⇩s⇩t [Decomp (Fun f T)]"
by (simp add: ik⇩e⇩s⇩t_append)
thus ?case
proof
assume "t' ∈ ik⇩e⇩s⇩t [Decomp (Fun f T)]"
hence "t' ∈ ik⇩e⇩s⇩t [Decomp (Fun f S)] ⋅⇩s⇩e⇩t ℐ"
using decomp_ik ‹Ana (Fun f T) = (K,M)› ‹Ana (Fun f S) = (KS,MS)› ‹M = MS ⋅⇩l⇩i⇩s⇩t ℐ›
by simp
thus ?case
using ideduct_synth_mono[
OF intruder_synth.AxiomC[of t' "ik⇩e⇩s⇩t [Decomp (Fun f S)] ⋅⇩s⇩e⇩t ℐ"],
of "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t (D'@[Decomp (Fun f S)]) ⋅⇩s⇩e⇩t ℐ)"]
by (auto simp add: ik⇩e⇩s⇩t_append)
next
assume "t' ∈ (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t D"
hence "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t'"
by (metis D'(2) intruder_synth.AxiomC)
hence "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t [Decomp (Fun f S)] ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t'"
by (simp add: ideduct_synth_mono)
thus ?case
using ik⇩e⇩s⇩t_append[of D' "[Decomp (Fun f S)]"]
image_Un[of "λx. x ⋅ ℐ" "ik⇩e⇩s⇩t D'" "ik⇩e⇩s⇩t [Decomp (Fun f S)]"]
by (simp add: sup_aci(2))
qed
qed auto
}
ultimately show ?thesis using D'' by auto
qed
next
case (Fun g S)
hence KM: "K = Ks ⋅⇩l⇩i⇩s⇩t ℐ" "M = Ms ⋅⇩l⇩i⇩s⇩t ℐ" "set K = set Ks ⋅⇩s⇩e⇩t ℐ" "set M = set Ms ⋅⇩s⇩e⇩t ℐ"
using fT_s_in(2) ‹Ana (Fun f T) = (K,M)› Ana_s s(2)
Ana_invar_substD[OF assms(5), of g S]
by auto
hence Ms_nonempty: "Ms ≠ []" using ‹M ≠ []› by auto
{ fix t' assume "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t (D@[Decomp (Fun f T)]) ⊢⇩c t'"
hence "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t (D'@[Decomp (Fun g S)]) ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t'" using AxiomC
proof (induction t' rule: intruder_synth_induct)
case (AxiomC t')
hence "t' ∈ ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ ∨ t' ∈ ik⇩e⇩s⇩t D ∨ t' ∈ set M"
by (simp add: decomp_ik ik⇩e⇩s⇩t_append)
thus ?case
proof (elim disjE)
assume "t' ∈ ik⇩e⇩s⇩t D"
hence *: "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t'" using D'(2) by simp
show ?case by (auto intro: ideduct_synth_mono[OF *] simp add: ik⇩e⇩s⇩t_append_subst(2))
next
assume "t' ∈ set M"
hence "t' ∈ ik⇩e⇩s⇩t [Decomp (Fun g S)] ⋅⇩s⇩e⇩t ℐ"
using KM(2) Fun decomp_ik[OF Ana_s] by auto
thus ?case by (simp add: image_Un ik⇩e⇩s⇩t_append)
qed (simp add: ideduct_synth_mono[OF intruder_synth.AxiomC])
qed auto
}
thus ?thesis
using s Fun Ana_s AxiomC.prems(1) KM(3) fT_s_in
decomps⇩e⇩s⇩t.Decomp[OF D'(1) _ _ Ms_nonempty, of g S Ks]
by (metis AxiomC.hyps image_Un image_eqI intruder_synth.AxiomC)
qed
next
case (ComposeC T f)
have *: "⋀m. m ∈ set M ⟹ (ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c m"
using Ana_fun_subterm[OF ‹Ana (Fun f T) = (K, M)›] ComposeC.hyps(3)
by auto
have **: "ik⇩e⇩s⇩t (D@[Decomp (Fun f T)]) = ik⇩e⇩s⇩t D ∪ set M"
using decomp_ik[OF ‹Ana (Fun f T) = (K, M)›] ik⇩e⇩s⇩t_append by auto
{ fix t' assume "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ ik⇩e⇩s⇩t (D@[Decomp (Fun f T)]) ⊢⇩c t'"
hence "(ik⇩e⇩s⇩t A ⋅⇩s⇩e⇩t ℐ) ∪ (ik⇩e⇩s⇩t D' ⋅⇩s⇩e⇩t ℐ) ⊢⇩c t'"
by (induct rule: intruder_synth_induct) (auto simp add: D'(2) * **)
}
thus ?case using D'(1) by auto
qed
qed
thus ?thesis using D(2) assms(1) by (auto simp add: ik⇩e⇩s⇩t_append_subst(2))
qed
private lemma wf⇩s⇩t⇩s'_update⇩s⇩t_nil: assumes "wf⇩s⇩t⇩s' 𝒮 𝒜" shows "wf⇩s⇩t⇩s' (update⇩s⇩t 𝒮 []) 𝒜"
using assms unfolding wf⇩s⇩t⇩s'_def by auto
private lemma wf⇩s⇩t⇩s'_update⇩s⇩t_snd:
assumes "wf⇩s⇩t⇩s' 𝒮 𝒜" "send⟨t⟩⇩s⇩t#S ∈ 𝒮"
shows "wf⇩s⇩t⇩s' (update⇩s⇩t 𝒮 (send⟨t⟩⇩s⇩t#S)) (𝒜@[Step (receive⟨t⟩⇩s⇩t)])"
unfolding wf⇩s⇩t⇩s'_def
proof (intro conjI)
let ?S = "send⟨t⟩⇩s⇩t#S"
let ?A = "𝒜@[Step (receive⟨t⟩⇩s⇩t)]"
have 𝒮: "⋀S'. S' ∈ update⇩s⇩t 𝒮 ?S ⟹ S' = S ∨ S' ∈ 𝒮" by auto
have 1: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t 𝒜) (dual⇩s⇩t S)" using assms unfolding wf⇩s⇩t⇩s'_def by auto
moreover have 2: "wfrestrictedvars⇩e⇩s⇩t ?A = wfrestrictedvars⇩e⇩s⇩t 𝒜 ∪ fv t"
using wfrestrictedvars⇩e⇩s⇩t_split(2) by (auto simp add: Un_assoc)
ultimately have 3: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" by (metis wf_vars_mono)
have 4: "∀S ∈ 𝒮. ∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" using assms unfolding wf⇩s⇩t⇩s'_def by simp
have "wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" using 1 2 3 assms(2) by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" by (metis 3 𝒮)
have "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t S = {}"
using 4 assms(2) unfolding wf⇩s⇩t⇩s'_def by force+
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. ∀S' ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" by (metis 4 𝒮)
have "∀S' ∈ 𝒮. fv⇩s⇩t ?S ∩ bvars⇩s⇩t S' = {}" "∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t ?S = {}"
using assms unfolding wf⇩s⇩t⇩s'_def by metis+
hence 5: "fv⇩e⇩s⇩t ?A = fv⇩e⇩s⇩t 𝒜 ∪ fv t" "bvars⇩e⇩s⇩t ?A = bvars⇩e⇩s⇩t 𝒜" "∀S' ∈ 𝒮. fv t ∩ bvars⇩s⇩t S' = {}"
using to_st_append by fastforce+
have *: "∀S ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}"
using 5 assms(1) unfolding wf⇩s⇩t⇩s'_def by fast
hence "fv⇩s⇩t ?S ∩ bvars⇩e⇩s⇩t ?A = {}" using assms(2) by metis
hence "fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by (metis * 𝒮)
have **: "∀S ∈ 𝒮. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}"
using 5 assms(1) unfolding wf⇩s⇩t⇩s'_def by fast
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t ?S = {}" using assms(2) by metis
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by fastforce
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by (metis ** 𝒮)
qed
private lemma wf⇩s⇩t⇩s'_update⇩s⇩t_rcv:
assumes "wf⇩s⇩t⇩s' 𝒮 𝒜" "receive⟨t⟩⇩s⇩t#S ∈ 𝒮"
shows "wf⇩s⇩t⇩s' (update⇩s⇩t 𝒮 (receive⟨t⟩⇩s⇩t#S)) (𝒜@[Step (send⟨t⟩⇩s⇩t)])"
unfolding wf⇩s⇩t⇩s'_def
proof (intro conjI)
let ?S = "receive⟨t⟩⇩s⇩t#S"
let ?A = "𝒜@[Step (send⟨t⟩⇩s⇩t)]"
have 𝒮: "⋀S'. S' ∈ update⇩s⇩t 𝒮 ?S ⟹ S' = S ∨ S' ∈ 𝒮" by auto
have 1: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t 𝒜) (dual⇩s⇩t S)" using assms unfolding wf⇩s⇩t⇩s'_def by auto
moreover have 2: "wfrestrictedvars⇩e⇩s⇩t ?A = wfrestrictedvars⇩e⇩s⇩t 𝒜 ∪ fv t"
using wfrestrictedvars⇩e⇩s⇩t_split(2) by (auto simp add: Un_assoc)
ultimately have 3: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" by (metis wf_vars_mono)
have 4: "∀S ∈ 𝒮. ∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" using assms unfolding wf⇩s⇩t⇩s'_def by simp
have "wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" using 1 2 3 assms(2) by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" by (metis 3 𝒮)
have "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t S = {}"
using 4 assms(2) unfolding wf⇩s⇩t⇩s'_def by force+
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. ∀S' ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" by (metis 4 𝒮)
have "∀S' ∈ 𝒮. fv⇩s⇩t ?S ∩ bvars⇩s⇩t S' = {}" "∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t ?S = {}"
using assms unfolding wf⇩s⇩t⇩s'_def by metis+
hence 5: "fv⇩e⇩s⇩t ?A = fv⇩e⇩s⇩t 𝒜 ∪ fv t" "bvars⇩e⇩s⇩t ?A = bvars⇩e⇩s⇩t 𝒜" "∀S' ∈ 𝒮. fv t ∩ bvars⇩s⇩t S' = {}"
using to_st_append by fastforce+
have *: "∀S ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}"
using 5 assms(1) unfolding wf⇩s⇩t⇩s'_def by fast
hence "fv⇩s⇩t ?S ∩ bvars⇩e⇩s⇩t ?A = {}" using assms(2) by metis
hence "fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by (metis * 𝒮)
have **: "∀S ∈ 𝒮. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}"
using 5 assms(1) unfolding wf⇩s⇩t⇩s'_def by fast
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t ?S = {}" using assms(2) by metis
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by fastforce
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by (metis ** 𝒮)
qed
private lemma wf⇩s⇩t⇩s'_update⇩s⇩t_eq:
assumes "wf⇩s⇩t⇩s' 𝒮 𝒜" "⟨a: t ≐ t'⟩⇩s⇩t#S ∈ 𝒮"
shows "wf⇩s⇩t⇩s' (update⇩s⇩t 𝒮 (⟨a: t ≐ t'⟩⇩s⇩t#S)) (𝒜@[Step (⟨a: t ≐ t'⟩⇩s⇩t)])"
unfolding wf⇩s⇩t⇩s'_def
proof (intro conjI)
let ?S = "⟨a: t ≐ t'⟩⇩s⇩t#S"
let ?A = "𝒜@[Step (⟨a: t ≐ t'⟩⇩s⇩t)]"
have 𝒮: "⋀S'. S' ∈ update⇩s⇩t 𝒮 ?S ⟹ S' = S ∨ S' ∈ 𝒮" by auto
have 1: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t 𝒜) (dual⇩s⇩t S)" using assms unfolding wf⇩s⇩t⇩s'_def by auto
moreover have 2:
"a = Assign ⟹ wfrestrictedvars⇩e⇩s⇩t ?A = wfrestrictedvars⇩e⇩s⇩t 𝒜 ∪ fv t ∪ fv t'"
"a = Check ⟹ wfrestrictedvars⇩e⇩s⇩t ?A = wfrestrictedvars⇩e⇩s⇩t 𝒜"
using wfrestrictedvars⇩e⇩s⇩t_split(2) by (auto simp add: Un_assoc)
ultimately have 3: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)"
by (cases a) (metis wf_vars_mono, metis)
have 4: "∀S ∈ 𝒮. ∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" using assms unfolding wf⇩s⇩t⇩s'_def by simp
have "wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" using 1 2 3 assms(2) by (cases a) auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" by (metis 3 𝒮)
have "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t S = {}"
using 4 assms(2) unfolding wf⇩s⇩t⇩s'_def by force+
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. ∀S' ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" by (metis 4 𝒮)
have "∀S' ∈ 𝒮. fv⇩s⇩t ?S ∩ bvars⇩s⇩t S' = {}" "∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t ?S = {}"
using assms unfolding wf⇩s⇩t⇩s'_def by metis+
hence 5: "fv⇩e⇩s⇩t ?A = fv⇩e⇩s⇩t 𝒜 ∪ fv t ∪ fv t'" "bvars⇩e⇩s⇩t ?A = bvars⇩e⇩s⇩t 𝒜"
"∀S' ∈ 𝒮. fv t ∩ bvars⇩s⇩t S' = {}" "∀S' ∈ 𝒮. fv t' ∩ bvars⇩s⇩t S' = {}"
using to_st_append by fastforce+
have *: "∀S ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}"
using 5 assms(1) unfolding wf⇩s⇩t⇩s'_def by fast
hence "fv⇩s⇩t ?S ∩ bvars⇩e⇩s⇩t ?A = {}" using assms(2) by metis
hence "fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by (metis * 𝒮)
have **: "∀S ∈ 𝒮. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}"
using 5 assms(1) unfolding wf⇩s⇩t⇩s'_def by fast
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t ?S = {}" using assms(2) by metis
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by fastforce
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by (metis ** 𝒮)
qed
private lemma wf⇩s⇩t⇩s'_update⇩s⇩t_ineq:
assumes "wf⇩s⇩t⇩s' 𝒮 𝒜" "∀X⟨∨≠: F⟩⇩s⇩t#S ∈ 𝒮"
shows "wf⇩s⇩t⇩s' (update⇩s⇩t 𝒮 (∀X⟨∨≠: F⟩⇩s⇩t#S)) (𝒜@[Step (∀X⟨∨≠: F⟩⇩s⇩t)])"
unfolding wf⇩s⇩t⇩s'_def
proof (intro conjI)
let ?S = "∀X⟨∨≠: F⟩⇩s⇩t#S"
let ?A = "𝒜@[Step (∀X⟨∨≠: F⟩⇩s⇩t)]"
have 𝒮: "⋀S'. S' ∈ update⇩s⇩t 𝒮 ?S ⟹ S' = S ∨ S' ∈ 𝒮" by auto
have 1: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t 𝒜) (dual⇩s⇩t S)" using assms unfolding wf⇩s⇩t⇩s'_def by auto
moreover have 2: "wfrestrictedvars⇩e⇩s⇩t ?A = wfrestrictedvars⇩e⇩s⇩t 𝒜"
using wfrestrictedvars⇩e⇩s⇩t_split(2) by (auto simp add: Un_assoc)
ultimately have 3: "∀S ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" by metis
have 4: "∀S ∈ 𝒮. ∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" using assms unfolding wf⇩s⇩t⇩s'_def by simp
have "wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" using 1 2 3 assms(2) by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t ?A) (dual⇩s⇩t S)" by (metis 3 𝒮)
have "fv⇩s⇩t S ∩ bvars⇩s⇩t S = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}"
"∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t S = {}"
using 4 assms(2) unfolding wf⇩s⇩t⇩s'_def by force+
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. ∀S' ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩s⇩t S' = {}" by (metis 4 𝒮)
have "∀S' ∈ 𝒮. fv⇩s⇩t ?S ∩ bvars⇩s⇩t S' = {}" "∀S' ∈ 𝒮. fv⇩s⇩t S' ∩ bvars⇩s⇩t ?S = {}"
using assms unfolding wf⇩s⇩t⇩s'_def by metis+
moreover have "fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ fv⇩s⇩t (∀X⟨∨≠: F⟩⇩s⇩t # S)" by auto
ultimately have 5:
"∀S' ∈ 𝒮. (fv⇩p⇩a⇩i⇩r⇩s F - set X) ∩ bvars⇩s⇩t S' = {}"
"fv⇩e⇩s⇩t ?A = fv⇩e⇩s⇩t 𝒜 ∪ (fv⇩p⇩a⇩i⇩r⇩s F - set X)" "bvars⇩e⇩s⇩t ?A = set X ∪ bvars⇩e⇩s⇩t 𝒜"
"∀S ∈ 𝒮. fv⇩s⇩t S ∩ set X = {}"
using to_st_append
by (blast, force, force, force)
have *: "∀S ∈ 𝒮. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" using 5(3,4) assms(1) unfolding wf⇩s⇩t⇩s'_def by blast
hence "fv⇩s⇩t ?S ∩ bvars⇩e⇩s⇩t ?A = {}" using assms(2) by metis
hence "fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t ?A = {}" by (metis * 𝒮)
have **: "∀S ∈ 𝒮. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}"
using 5(1,2) assms(1) unfolding wf⇩s⇩t⇩s'_def by fast
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t ?S = {}" using assms(2) by metis
hence "fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by auto
thus "∀S ∈ update⇩s⇩t 𝒮 ?S. fv⇩e⇩s⇩t ?A ∩ bvars⇩s⇩t S = {}" by (metis ** 𝒮)
qed
private lemma trms⇩s⇩t_update⇩s⇩t_eq:
assumes "x#S ∈ 𝒮"
shows "⋃(trms⇩s⇩t ` update⇩s⇩t 𝒮 (x#S)) ∪ trms⇩s⇩t⇩p x = ⋃(trms⇩s⇩t ` 𝒮)" (is "?A = ?B")
proof
show "?B ⊆ ?A"
proof
have "trms⇩s⇩t⇩p x ⊆ trms⇩s⇩t (x#S)" by auto
hence "⋀t'. t' ∈ ?B ⟹ t' ∈ trms⇩s⇩t⇩p x ⟹ t' ∈ ?A" by simp
moreover {
fix t' assume t': "t' ∈ ?B" "t' ∉ trms⇩s⇩t⇩p x"
then obtain S' where S': "t' ∈ trms⇩s⇩t S'" "S' ∈ 𝒮" by auto
hence "S' = x#S ∨ S' ∈ update⇩s⇩t 𝒮 (x#S)" by auto
moreover {
assume "S' = x#S"
hence "t' ∈ trms⇩s⇩t S" using S' t' by simp
hence "t' ∈ ?A" by auto
}
ultimately have "t' ∈ ?A" using t' S' by auto
}
ultimately show "⋀t'. t' ∈ ?B ⟹ t' ∈ ?A" by metis
qed
show "?A ⊆ ?B"
proof
have "⋀t'. t' ∈ ?A ⟹ t' ∈ trms⇩s⇩t⇩p x ⟹ trms⇩s⇩t⇩p x ⊆ ?B"
using assms by force+
moreover {
fix t' assume t': "t' ∈ ?A" "t' ∉ trms⇩s⇩t⇩p x"
then obtain S' where "t' ∈ trms⇩s⇩t S'" "S' ∈ update⇩s⇩t 𝒮 (x#S)" by auto
hence "S' = S ∨ S' ∈ 𝒮" by auto
moreover have "trms⇩s⇩t S ⊆ ?B" using assms trms⇩s⇩t_cons[of x S] by blast
ultimately have "t' ∈ ?B" using t' by fastforce
}
ultimately show "⋀t'. t' ∈ ?A ⟹ t' ∈ ?B" by blast
qed
qed
private lemma trms⇩s⇩t_update⇩s⇩t_eq_snd:
assumes "send⟨t⟩⇩s⇩t#S ∈ 𝒮" "𝒮' = update⇩s⇩t 𝒮 (send⟨t⟩⇩s⇩t#S)" "𝒜' = 𝒜@[Step (receive⟨t⟩⇩s⇩t)]"
shows "(⋃(trms⇩s⇩t ` 𝒮)) ∪ (trms⇩e⇩s⇩t 𝒜) = (⋃(trms⇩s⇩t ` 𝒮')) ∪ (trms⇩e⇩s⇩t 𝒜')"
proof -
have "(trms⇩e⇩s⇩t 𝒜') = (trms⇩e⇩s⇩t 𝒜) ∪ {t}" "⋃(trms⇩s⇩t ` 𝒮') ∪ {t} = ⋃(trms⇩s⇩t ` 𝒮)"
using to_st_append trms⇩s⇩t_update⇩s⇩t_eq[OF assms(1)] assms(2,3) by auto
thus ?thesis
by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral)
qed
private lemma trms⇩s⇩t_update⇩s⇩t_eq_rcv:
assumes "receive⟨t⟩⇩s⇩t#S ∈ 𝒮" "𝒮' = update⇩s⇩t 𝒮 (receive⟨t⟩⇩s⇩t#S)" "𝒜' = 𝒜@[Step (send⟨t⟩⇩s⇩t)]"
shows "(⋃(trms⇩s⇩t ` 𝒮)) ∪ (trms⇩e⇩s⇩t 𝒜) = (⋃(trms⇩s⇩t ` 𝒮')) ∪ (trms⇩e⇩s⇩t 𝒜')"
proof -
have "(trms⇩e⇩s⇩t 𝒜') = (trms⇩e⇩s⇩t 𝒜) ∪ {t}" "⋃(trms⇩s⇩t ` 𝒮') ∪ {t} = ⋃(trms⇩s⇩t ` 𝒮)"
using to_st_append trms⇩s⇩t_update⇩s⇩t_eq[OF assms(1)] assms(2,3) by auto
thus ?thesis
by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral)
qed
private lemma trms⇩s⇩t_update⇩s⇩t_eq_eq:
assumes "⟨a: t ≐ t'⟩⇩s⇩t#S ∈ 𝒮" "𝒮' = update⇩s⇩t 𝒮 (⟨a: t ≐ t'⟩⇩s⇩t#S)" "𝒜' = 𝒜@[Step (⟨a: t ≐ t'⟩⇩s⇩t)]"
shows "(⋃(trms⇩s⇩t ` 𝒮)) ∪ (trms⇩e⇩s⇩t 𝒜) = (⋃(trms⇩s⇩t ` 𝒮')) ∪ (trms⇩e⇩s⇩t 𝒜')"
proof -
have "(trms⇩e⇩s⇩t 𝒜') = (trms⇩e⇩s⇩t 𝒜) ∪ {t,t'}" "⋃(trms⇩s⇩t ` 𝒮') ∪ {t,t'} = ⋃(trms⇩s⇩t ` 𝒮)"
using to_st_append trms⇩s⇩t_update⇩s⇩t_eq[OF assms(1)] assms(2,3) by auto
thus ?thesis
by (metis (no_types, lifting) Un_insert_left Un_insert_right sup_bot.right_neutral)
qed
private lemma trms⇩s⇩t_update⇩s⇩t_eq_ineq:
assumes "∀X⟨∨≠: F⟩⇩s⇩t#S ∈ 𝒮" "𝒮' = update⇩s⇩t 𝒮 (∀X⟨∨≠: F⟩⇩s⇩t#S)" "𝒜' = 𝒜@[Step (∀X⟨∨≠: F⟩⇩s⇩t)]"
shows "(⋃(trms⇩s⇩t ` 𝒮)) ∪ (trms⇩e⇩s⇩t 𝒜) = (⋃(trms⇩s⇩t ` 𝒮')) ∪ (trms⇩e⇩s⇩t 𝒜')"
proof -
have "(trms⇩e⇩s⇩t 𝒜') = (trms⇩e⇩s⇩t 𝒜) ∪ trms⇩p⇩a⇩i⇩r⇩s F" "⋃(trms⇩s⇩t ` 𝒮') ∪ trms⇩p⇩a⇩i⇩r⇩s F = ⋃(trms⇩s⇩t ` 𝒮)"
using to_st_append trms⇩s⇩t_update⇩s⇩t_eq[OF assms(1)] assms(2,3) by auto
thus ?thesis by (simp add: Un_commute sup_left_commute)
qed
private lemma ik⇩s⇩t_update⇩s⇩t_subset:
assumes "x#S ∈ 𝒮"
shows "⋃(ik⇩s⇩t`dual⇩s⇩t ` (update⇩s⇩t 𝒮 (x#S))) ⊆ ⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)" (is ?A)
"⋃(assignment_rhs⇩s⇩t ` (update⇩s⇩t 𝒮 (x#S))) ⊆ ⋃(assignment_rhs⇩s⇩t ` 𝒮)" (is ?B)
proof -
{ fix t assume "t ∈ ⋃(ik⇩s⇩t`dual⇩s⇩t ` (update⇩s⇩t 𝒮 (x#S)))"
then obtain S' where S': "S' ∈ update⇩s⇩t 𝒮 (x#S)" "t ∈ ik⇩s⇩t (dual⇩s⇩t S')" by auto
have *: "ik⇩s⇩t (dual⇩s⇩t S) ⊆ ik⇩s⇩t (dual⇩s⇩t (x#S))"
using ik_append[of "dual⇩s⇩t [x]" "dual⇩s⇩t S"] dual⇩s⇩t_append[of "[x]" S]
by auto
hence "t ∈ ⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)"
proof (cases "S' = S")
case True thus ?thesis using * assms S' by auto
next
case False thus ?thesis using S' by auto
qed
}
moreover
{ fix t assume "t ∈ ⋃(assignment_rhs⇩s⇩t ` (update⇩s⇩t 𝒮 (x#S)))"
then obtain S' where S': "S' ∈ update⇩s⇩t 𝒮 (x#S)" "t ∈ assignment_rhs⇩s⇩t S'" by auto
have "assignment_rhs⇩s⇩t S ⊆ assignment_rhs⇩s⇩t (x#S)"
using assignment_rhs_append[of "[x]" S] by simp
hence "t ∈ ⋃(assignment_rhs⇩s⇩t ` 𝒮)"
using assms S' by (cases "S' = S") auto
}
ultimately show ?A ?B by (metis subsetI)+
qed
private lemma ik⇩s⇩t_update⇩s⇩t_subset_snd:
assumes "send⟨t⟩⇩s⇩t#S ∈ 𝒮"
"𝒮' = update⇩s⇩t 𝒮 (send⟨t⟩⇩s⇩t#S)"
"𝒜' = 𝒜@[Step (receive⟨t⟩⇩s⇩t)]"
shows "(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜') ⊆
(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)" (is ?A)
"(⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜') ⊆
(⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)" (is ?B)
proof -
{ fix t' assume t'_in: "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜')"
hence "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜) ∪ {t}" using assms ik⇩e⇩s⇩t_append by auto
moreover have "t ∈ ⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)" using assms(1) by force
ultimately have "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)"
using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) by auto
}
moreover
{ fix t' assume t'_in: "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜')"
hence "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)"
using assms assignment_rhs⇩e⇩s⇩t_append by auto
hence "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)"
using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) by auto
}
ultimately show ?A ?B by (metis subsetI)+
qed
private lemma ik⇩s⇩t_update⇩s⇩t_subset_rcv:
assumes "receive⟨t⟩⇩s⇩t#S ∈ 𝒮"
"𝒮' = update⇩s⇩t 𝒮 (receive⟨t⟩⇩s⇩t#S)"
"𝒜' = 𝒜@[Step (send⟨t⟩⇩s⇩t)]"
shows "(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜') ⊆
(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)" (is ?A)
"(⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜') ⊆
(⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)" (is ?B)
proof -
{ fix t' assume t'_in: "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜')"
hence "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜)" using assms ik⇩e⇩s⇩t_append by auto
hence "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)"
using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) by auto
}
moreover
{ fix t' assume t'_in: "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜')"
hence "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)"
using assms assignment_rhs⇩e⇩s⇩t_append by auto
hence "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)"
using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) by auto
}
ultimately show ?A ?B by (metis subsetI)+
qed
private lemma ik⇩s⇩t_update⇩s⇩t_subset_eq:
assumes "⟨a: t ≐ t'⟩⇩s⇩t#S ∈ 𝒮"
"𝒮' = update⇩s⇩t 𝒮 (⟨a: t ≐ t'⟩⇩s⇩t#S)"
"𝒜' = 𝒜@[Step (⟨a: t ≐ t'⟩⇩s⇩t)]"
shows "(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜') ⊆
(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)" (is ?A)
"(⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜') ⊆
(⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)" (is ?B)
proof -
have 1: "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)"
when "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜')"
for t'
proof -
have "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜)" using that assms ik⇩e⇩s⇩t_append by auto
thus ?thesis using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) by auto
qed
have 2: "t'' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)"
when "t'' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜')" "a = Assign"
for t''
proof -
have "t'' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜) ∪ {t'}"
using that assms assignment_rhs⇩e⇩s⇩t_append by auto
moreover have "t' ∈ ⋃(assignment_rhs⇩s⇩t ` 𝒮)" using assms(1) that by force
ultimately show ?thesis using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) that by auto
qed
have 3: "assignment_rhs⇩e⇩s⇩t 𝒜' = assignment_rhs⇩e⇩s⇩t 𝒜" (is ?C)
"(⋃(assignment_rhs⇩s⇩t ` 𝒮')) ⊆ (⋃(assignment_rhs⇩s⇩t ` 𝒮))" (is ?D)
when "a = Check"
proof -
show ?C using that assms(2,3) by (simp add: assignment_rhs⇩e⇩s⇩t_append)
show ?D using assms(1,2,3) ik⇩s⇩t_update⇩s⇩t_subset(2) by auto
qed
show ?A using 1 2 by (metis subsetI)
show ?B using 1 2 3 by (cases a) blast+
qed
private lemma ik⇩s⇩t_update⇩s⇩t_subset_ineq:
assumes "∀X⟨∨≠: F⟩⇩s⇩t#S ∈ 𝒮"
"𝒮' = update⇩s⇩t 𝒮 (∀X⟨∨≠: F⟩⇩s⇩t#S)"
"𝒜' = 𝒜@[Step (∀X⟨∨≠: F⟩⇩s⇩t)]"
shows "(⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜') ⊆
(⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)" (is ?A)
"(⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜') ⊆
(⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)" (is ?B)
proof -
{ fix t' assume t'_in: "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜')"
hence "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮')) ∪ (ik⇩e⇩s⇩t 𝒜)" using assms ik⇩e⇩s⇩t_append by auto
hence "t' ∈ (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮)) ∪ (ik⇩e⇩s⇩t 𝒜)"
using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) by auto
}
moreover
{ fix t' assume t'_in: "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜')"
hence "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮')) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)"
using assms assignment_rhs⇩e⇩s⇩t_append by auto
hence "t' ∈ (⋃(assignment_rhs⇩s⇩t ` 𝒮)) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)"
using ik⇩s⇩t_update⇩s⇩t_subset[OF assms(1)] assms(2) by auto
}
ultimately show ?A ?B by (metis subsetI)+
qed
subsubsection ‹Transition Systems Definitions›
inductive pts_symbolic::
"(('fun,'var) strands × ('fun,'var) strand) ⇒
(('fun,'var) strands × ('fun,'var) strand) ⇒ bool"
(infix "⇒⇧∙" 50) where
Nil[simp]: "[] ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙ (update⇩s⇩t 𝒮 [],𝒜)"
| Send[simp]: "send⟨t⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙ (update⇩s⇩t 𝒮 (send⟨t⟩⇩s⇩t#S),𝒜@[receive⟨t⟩⇩s⇩t])"
| Receive[simp]: "receive⟨t⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙ (update⇩s⇩t 𝒮 (receive⟨t⟩⇩s⇩t#S),𝒜@[send⟨t⟩⇩s⇩t])"
| Equality[simp]: "⟨a: t ≐ t'⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙ (update⇩s⇩t 𝒮 (⟨a: t ≐ t'⟩⇩s⇩t#S),𝒜@[⟨a: t ≐ t'⟩⇩s⇩t])"
| Inequality[simp]: "∀X⟨∨≠: F⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙ (update⇩s⇩t 𝒮 (∀X⟨∨≠: F⟩⇩s⇩t#S),𝒜@[∀X⟨∨≠: F⟩⇩s⇩t])"
private inductive pts_symbolic_c::
"(('fun,'var) strands × ('fun,'var) extstrand) ⇒
(('fun,'var) strands × ('fun,'var) extstrand) ⇒ bool"
(infix "⇒⇧∙⇩c" 50) where
Nil[simp]: "[] ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙⇩c (update⇩s⇩t 𝒮 [],𝒜)"
| Send[simp]: "send⟨t⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙⇩c (update⇩s⇩t 𝒮 (send⟨t⟩⇩s⇩t#S),𝒜@[Step (receive⟨t⟩⇩s⇩t)])"
| Receive[simp]: "receive⟨t⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙⇩c (update⇩s⇩t 𝒮 (receive⟨t⟩⇩s⇩t#S),𝒜@[Step (send⟨t⟩⇩s⇩t)])"
| Equality[simp]: "⟨a: t ≐ t'⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙⇩c (update⇩s⇩t 𝒮 (⟨a: t ≐ t'⟩⇩s⇩t#S),𝒜@[Step (⟨a: t ≐ t'⟩⇩s⇩t)])"
| Inequality[simp]: "∀X⟨∨≠: F⟩⇩s⇩t#S ∈ 𝒮 ⟹ (𝒮,𝒜) ⇒⇧∙⇩c (update⇩s⇩t 𝒮 (∀X⟨∨≠: F⟩⇩s⇩t#S),𝒜@[Step (∀X⟨∨≠: F⟩⇩s⇩t)])"
| Decompose[simp]: "Fun f T ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t 𝒜 ∪ assignment_rhs⇩e⇩s⇩t 𝒜)
⟹ (𝒮,𝒜) ⇒⇧∙⇩c (𝒮,𝒜@[Decomp (Fun f T)])"
abbreviation pts_symbolic_rtrancl (infix "⇒⇧∙⇧*" 50) where "a ⇒⇧∙⇧* b ≡ pts_symbolic⇧*⇧* a b"
private abbreviation pts_symbolic_c_rtrancl (infix "⇒⇧∙⇩c⇧*" 50) where "a ⇒⇧∙⇩c⇧* b ≡ pts_symbolic_c⇧*⇧* a b"
lemma pts_symbolic_induct[consumes 1, case_names Nil Send Receive Equality Inequality]:
assumes "(𝒮,𝒜) ⇒⇧∙ (𝒮',𝒜')"
and "⟦[] ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 []; 𝒜' = 𝒜⟧ ⟹ P"
and "⋀t S. ⟦send⟨t⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (send⟨t⟩⇩s⇩t#S); 𝒜' = 𝒜@[receive⟨t⟩⇩s⇩t]⟧ ⟹ P"
and "⋀t S. ⟦receive⟨t⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (receive⟨t⟩⇩s⇩t#S); 𝒜' = 𝒜@[send⟨t⟩⇩s⇩t]⟧ ⟹ P"
and "⋀a t t' S. ⟦⟨a: t ≐ t'⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (⟨a: t ≐ t'⟩⇩s⇩t#S); 𝒜' = 𝒜@[⟨a: t ≐ t'⟩⇩s⇩t]⟧ ⟹ P"
and "⋀X F S. ⟦∀X⟨∨≠: F⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (∀X⟨∨≠: F⟩⇩s⇩t#S); 𝒜' = 𝒜@[∀X⟨∨≠: F⟩⇩s⇩t]⟧ ⟹ P"
shows "P"
apply (rule pts_symbolic.cases[OF assms(1)])
using assms(2,3,4,5,6) by simp_all
private lemma pts_symbolic_c_induct[consumes 1, case_names Nil Send Receive Equality Inequality Decompose]:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c (𝒮',𝒜')"
and "⟦[] ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 []; 𝒜' = 𝒜⟧ ⟹ P"
and "⋀t S. ⟦send⟨t⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (send⟨t⟩⇩s⇩t#S); 𝒜' = 𝒜@[Step (receive⟨t⟩⇩s⇩t)]⟧ ⟹ P"
and "⋀t S. ⟦receive⟨t⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (receive⟨t⟩⇩s⇩t#S); 𝒜' = 𝒜@[Step (send⟨t⟩⇩s⇩t)]⟧ ⟹ P"
and "⋀a t t' S. ⟦⟨a: t ≐ t'⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (⟨a: t ≐ t'⟩⇩s⇩t#S); 𝒜' = 𝒜@[Step (⟨a: t ≐ t'⟩⇩s⇩t)]⟧ ⟹ P"
and "⋀X F S. ⟦∀X⟨∨≠: F⟩⇩s⇩t#S ∈ 𝒮; 𝒮' = update⇩s⇩t 𝒮 (∀X⟨∨≠: F⟩⇩s⇩t#S); 𝒜' = 𝒜@[Step (∀X⟨∨≠: F⟩⇩s⇩t)]⟧ ⟹ P"
and "⋀f T. ⟦Fun f T ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t 𝒜 ∪ assignment_rhs⇩e⇩s⇩t 𝒜); 𝒮' = 𝒮; 𝒜' = 𝒜@[Decomp (Fun f T)]⟧ ⟹ P"
shows "P"
apply (rule pts_symbolic_c.cases[OF assms(1)])
using assms(2,3,4,5,6,7) by simp_all
private lemma pts_symbolic_c_preserves_wf_prot:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')" "wf⇩s⇩t⇩s' 𝒮 𝒜"
shows "wf⇩s⇩t⇩s' 𝒮' 𝒜'"
using assms
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
from step.hyps(2) step.IH[OF step.prems] show ?case
proof (induction rule: pts_symbolic_c_induct)
case Decompose
hence "fv⇩e⇩s⇩t 𝒜2 = fv⇩e⇩s⇩t 𝒜1" "bvars⇩e⇩s⇩t 𝒜2 = bvars⇩e⇩s⇩t 𝒜1"
using bvars_decomp ik_assignment_rhs_decomp_fv by metis+
thus ?case using Decompose unfolding wf⇩s⇩t⇩s'_def
by (metis wf_vars_mono wfrestrictedvars⇩e⇩s⇩t_split(2))
qed (metis wf⇩s⇩t⇩s'_update⇩s⇩t_nil, metis wf⇩s⇩t⇩s'_update⇩s⇩t_snd,
metis wf⇩s⇩t⇩s'_update⇩s⇩t_rcv, metis wf⇩s⇩t⇩s'_update⇩s⇩t_eq,
metis wf⇩s⇩t⇩s'_update⇩s⇩t_ineq)
qed metis
private lemma pts_symbolic_c_preserves_wf_is:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')" "wf⇩s⇩t⇩s' 𝒮 𝒜" "wf⇩s⇩t V (to_st 𝒜)"
shows "wf⇩s⇩t V (to_st 𝒜')"
using assms
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
hence "(𝒮, 𝒜) ⇒⇧∙⇩c⇧* (𝒮2, 𝒜2)" by auto
hence *: "wf⇩s⇩t⇩s' 𝒮1 𝒜1" "wf⇩s⇩t⇩s' 𝒮2 𝒜2"
using pts_symbolic_c_preserves_wf_prot[OF _ step.prems(1)] step.hyps(1)
by auto
from step.hyps(2) step.IH[OF step.prems] show ?case
proof (induction rule: pts_symbolic_c_induct)
case Nil thus ?case by auto
next
case (Send t S)
hence "wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t 𝒜1) (receive⟨t⟩⇩s⇩t#(dual⇩s⇩t S))"
using *(1) unfolding wf⇩s⇩t⇩s'_def by fastforce
hence "fv t ⊆ wfrestrictedvars⇩s⇩t (to_st 𝒜1) ∪ V"
using wfrestrictedvars⇩e⇩s⇩t_eq_wfrestrictedvars⇩s⇩t by auto
thus ?case using Send wf_rcv_append''' to_st_append by simp
next
case (Receive t) thus ?case using wf_snd_append to_st_append by simp
next
case (Equality a t t' S)
hence "wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t 𝒜1) (⟨a: t ≐ t'⟩⇩s⇩t#(dual⇩s⇩t S))"
using *(1) unfolding wf⇩s⇩t⇩s'_def by fastforce
hence "fv t' ⊆ wfrestrictedvars⇩s⇩t (to_st 𝒜1) ∪ V" when "a = Assign"
using wfrestrictedvars⇩e⇩s⇩t_eq_wfrestrictedvars⇩s⇩t that by auto
thus ?case using Equality wf_eq_append''' to_st_append by (cases a) auto
next
case (Inequality t t' S) thus ?case using wf_ineq_append'' to_st_append by simp
next
case (Decompose f T)
hence "fv (Fun f T) ⊆ wfrestrictedvars⇩e⇩s⇩t 𝒜1"
by (metis fv_subterms_set fv_subset subset_trans
ik⇩s⇩t_assignment_rhs⇩s⇩t_wfrestrictedvars_subset)
hence "vars⇩s⇩t (decomp (Fun f T)) ⊆ wfrestrictedvars⇩s⇩t (to_st 𝒜1) ∪ V"
using decomp_vars[of "Fun f T"] wfrestrictedvars⇩e⇩s⇩t_eq_wfrestrictedvars⇩s⇩t[of 𝒜1] by auto
thus ?case
using to_st_append[of 𝒜1 "[Decomp (Fun f T)]"]
wf_append_suffix[OF Decompose.prems] Decompose.hyps(3)
by (metis append_Nil2 decomp_vars(1,2) to_st.simps(1,3))
qed
qed metis
private lemma pts_symbolic_c_preserves_tfr⇩s⇩e⇩t:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')"
and "tfr⇩s⇩e⇩t ((⋃(trms⇩s⇩t ` 𝒮)) ∪ (trms⇩e⇩s⇩t 𝒜))"
and "wf⇩t⇩r⇩m⇩s ((⋃(trms⇩s⇩t ` 𝒮)) ∪ (trms⇩e⇩s⇩t 𝒜))"
shows "tfr⇩s⇩e⇩t ((⋃(trms⇩s⇩t ` 𝒮')) ∪ (trms⇩e⇩s⇩t 𝒜')) ∧ wf⇩t⇩r⇩m⇩s ((⋃(trms⇩s⇩t ` 𝒮')) ∪ (trms⇩e⇩s⇩t 𝒜'))"
using assms
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
from step.hyps(2) step.IH[OF step.prems] show ?case
proof (induction rule: pts_symbolic_c_induct)
case Nil
hence "⋃(trms⇩s⇩t ` 𝒮1) = ⋃(trms⇩s⇩t ` 𝒮2)" by force
thus ?case using Nil by metis
next
case (Decompose f T)
obtain t where t: "t ∈ ik⇩e⇩s⇩t 𝒜1 ∪ assignment_rhs⇩e⇩s⇩t 𝒜1" "Fun f T ⊑ t"
using Decompose.hyps(1) by auto
have t_wf: "wf⇩t⇩r⇩m t"
using Decompose.prems wf_trm_subterm[of _ t]
trms⇩e⇩s⇩t_ik_assignment_rhsI[OF t(1)]
unfolding tfr⇩s⇩e⇩t_def
by (metis UN_E Un_iff)
have "t ∈ subterms⇩s⇩e⇩t (trms⇩e⇩s⇩t 𝒜1)" using trms⇩e⇩s⇩t_ik_assignment_rhsI t by auto
hence "Fun f T ∈ SMP (trms⇩e⇩s⇩t 𝒜1)"
by (metis (no_types) SMP.MP SMP.Subterm UN_E t(2))
hence "{Fun f T} ⊆ SMP (trms⇩e⇩s⇩t 𝒜1)" using SMP.Subterm[of "Fun f T"] by auto
moreover have "trms⇩e⇩s⇩t 𝒜2 = insert (Fun f T) (trms⇩e⇩s⇩t 𝒜1)"
using Decompose.hyps(3) by auto
ultimately have *: "SMP (trms⇩e⇩s⇩t 𝒜1) = SMP (trms⇩e⇩s⇩t 𝒜2)"
using SMP_subset_union_eq[of "{Fun f T}"]
by (simp add: Un_commute)
hence "SMP ((⋃(trms⇩s⇩t ` 𝒮1)) ∪ (trms⇩e⇩s⇩t 𝒜1)) = SMP ((⋃(trms⇩s⇩t ` 𝒮2)) ∪ (trms⇩e⇩s⇩t 𝒜2))"
using Decompose.hyps(2) SMP_union by auto
moreover have "∀t ∈ trms⇩e⇩s⇩t 𝒜1. wf⇩t⇩r⇩m t" "wf⇩t⇩r⇩m (Fun f T)"
using Decompose.prems wf_trm_subterm t(2) t_wf unfolding tfr⇩s⇩e⇩t_def by auto
hence "∀t ∈ trms⇩e⇩s⇩t 𝒜2. wf⇩t⇩r⇩m t" by (metis * SMP.MP SMP_wf_trm)
hence "∀t ∈ (⋃(trms⇩s⇩t ` 𝒮2)) ∪ (trms⇩e⇩s⇩t 𝒜2). wf⇩t⇩r⇩m t"
using Decompose.prems Decompose.hyps(2) unfolding tfr⇩s⇩e⇩t_def by force
ultimately show ?thesis using Decompose.prems unfolding tfr⇩s⇩e⇩t_def by presburger
qed (metis trms⇩s⇩t_update⇩s⇩t_eq_snd, metis trms⇩s⇩t_update⇩s⇩t_eq_rcv,
metis trms⇩s⇩t_update⇩s⇩t_eq_eq, metis trms⇩s⇩t_update⇩s⇩t_eq_ineq)
qed metis
private lemma pts_symbolic_c_preserves_tfr⇩s⇩t⇩p:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')" "∀S ∈ 𝒮 ∪ {to_st 𝒜}. list_all tfr⇩s⇩t⇩p S"
shows "∀S ∈ 𝒮' ∪ {to_st 𝒜'}. list_all tfr⇩s⇩t⇩p S"
using assms
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
from step.hyps(2) step.IH[OF step.prems] show ?case
proof (induction rule: pts_symbolic_c_induct)
case Nil
have 1: "∀S ∈ {to_st 𝒜2}. list_all tfr⇩s⇩t⇩p S" using Nil by simp
have 2: "𝒮2 = 𝒮1 - {[]}" "∀S ∈ 𝒮1. list_all tfr⇩s⇩t⇩p S" using Nil by simp_all
have "∀S ∈ 𝒮2. list_all tfr⇩s⇩t⇩p S"
proof
fix S assume "S ∈ 𝒮2"
hence "S ∈ 𝒮1" using 2(1) by simp
thus "list_all tfr⇩s⇩t⇩p S" using 2(2) by simp
qed
thus ?case using 1 by auto
next
case (Send t S)
have 1: "∀S ∈ {to_st 𝒜2}. list_all tfr⇩s⇩t⇩p S" using Send by (simp add: to_st_append)
have 2: "𝒮2 = insert S (𝒮1 - {send⟨t⟩⇩s⇩t#S})" "∀S ∈ 𝒮1. list_all tfr⇩s⇩t⇩p S" using Send by simp_all
have 3: "∀S ∈ 𝒮2. list_all tfr⇩s⇩t⇩p S"
proof
fix S' assume "S' ∈ 𝒮2"
hence "S' ∈ 𝒮1 ∨ S' = S" using 2(1) by auto
moreover have "list_all tfr⇩s⇩t⇩p S" using Send.hyps 2(2) by auto
ultimately show "list_all tfr⇩s⇩t⇩p S'" using 2(2) by blast
qed
thus ?case using 1 by auto
next
case (Receive t S)
have 1: "∀S ∈ {to_st 𝒜2}. list_all tfr⇩s⇩t⇩p S" using Receive by (simp add: to_st_append)
have 2: "𝒮2 = insert S (𝒮1 - {receive⟨t⟩⇩s⇩t#S})" "∀S ∈ 𝒮1. list_all tfr⇩s⇩t⇩p S"
using Receive by simp_all
have 3: "∀S ∈ 𝒮2. list_all tfr⇩s⇩t⇩p S"
proof
fix S' assume "S' ∈ 𝒮2"
hence "S' ∈ 𝒮1 ∨ S' = S" using 2(1) by auto
moreover have "list_all tfr⇩s⇩t⇩p S" using Receive.hyps 2(2) by auto
ultimately show "list_all tfr⇩s⇩t⇩p S'" using 2(2) by blast
qed
show ?case using 1 3 by auto
next
case (Equality a t t' S)
have 1: "to_st 𝒜2 = to_st 𝒜1@[⟨a: t ≐ t'⟩⇩s⇩t]" "list_all tfr⇩s⇩t⇩p (to_st 𝒜1)"
using Equality by (simp_all add: to_st_append)
have 2: "list_all tfr⇩s⇩t⇩p [⟨a: t ≐ t'⟩⇩s⇩t]" using Equality by fastforce
have 3: "list_all tfr⇩s⇩t⇩p (to_st 𝒜2)"
using tfr_stp_all_append[of "to_st 𝒜1" "[⟨a: t ≐ t'⟩⇩s⇩t]"] 1 2 by metis
hence 4: "∀S ∈ {to_st 𝒜2}. list_all tfr⇩s⇩t⇩p S" using Equality by simp
have 5: "𝒮2 = insert S (𝒮1 - {⟨a: t ≐ t'⟩⇩s⇩t#S})" "∀S ∈ 𝒮1. list_all tfr⇩s⇩t⇩p S"
using Equality by simp_all
have 6: "∀S ∈ 𝒮2. list_all tfr⇩s⇩t⇩p S"
proof
fix S' assume "S' ∈ 𝒮2"
hence "S' ∈ 𝒮1 ∨ S' = S" using 5(1) by auto
moreover have "list_all tfr⇩s⇩t⇩p S" using Equality.hyps 5(2) by auto
ultimately show "list_all tfr⇩s⇩t⇩p S'" using 5(2) by blast
qed
thus ?case using 4 by auto
next
case (Inequality X F S)
have 1: "to_st 𝒜2 = to_st 𝒜1@[∀X⟨∨≠: F⟩⇩s⇩t]" "list_all tfr⇩s⇩t⇩p (to_st 𝒜1)"
using Inequality by (simp_all add: to_st_append)
have "list_all tfr⇩s⇩t⇩p (∀X⟨∨≠: F⟩⇩s⇩t#S)" using Inequality(1,4) by blast
hence 2: "list_all tfr⇩s⇩t⇩p [∀X⟨∨≠: F⟩⇩s⇩t]" by simp
have 3: "list_all tfr⇩s⇩t⇩p (to_st 𝒜2)"
using tfr_stp_all_append[of "to_st 𝒜1" "[∀X⟨∨≠: F⟩⇩s⇩t]"] 1 2 by metis
hence 4: "∀S ∈ {to_st 𝒜2}. list_all tfr⇩s⇩t⇩p S" using Inequality by simp
have 5: "𝒮2 = insert S (𝒮1 - {∀X⟨∨≠: F⟩⇩s⇩t#S})" "∀S ∈ 𝒮1. list_all tfr⇩s⇩t⇩p S"
using Inequality by simp_all
have 6: "∀S ∈ 𝒮2. list_all tfr⇩s⇩t⇩p S"
proof
fix S' assume "S' ∈ 𝒮2"
hence "S' ∈ 𝒮1 ∨ S' = S" using 5(1) by auto
moreover have "list_all tfr⇩s⇩t⇩p S" using Inequality.hyps 5(2) by auto
ultimately show "list_all tfr⇩s⇩t⇩p S'" using 5(2) by blast
qed
thus ?case using 4 by auto
next
case (Decompose f T)
hence 1: "∀S ∈ 𝒮2. list_all tfr⇩s⇩t⇩p S" by blast
have 2: "list_all tfr⇩s⇩t⇩p (to_st 𝒜1)" "list_all tfr⇩s⇩t⇩p (to_st [Decomp (Fun f T)])"
using Decompose.prems decomp_tfr⇩s⇩t⇩p by auto
hence "list_all tfr⇩s⇩t⇩p (to_st 𝒜1@to_st [Decomp (Fun f T)])" by auto
hence "list_all tfr⇩s⇩t⇩p (to_st 𝒜2)"
using Decompose.hyps(3) to_st_append[of 𝒜1 "[Decomp (Fun f T)]"]
by auto
thus ?case using 1 by blast
qed
qed
private lemma pts_symbolic_c_preserves_well_analyzed:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')" "well_analyzed 𝒜"
shows "well_analyzed 𝒜'"
using assms
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
from step.hyps(2) step.IH[OF step.prems] show ?case
proof (induction rule: pts_symbolic_c_induct)
case Receive thus ?case by (metis well_analyzed_singleton(1) well_analyzed_append)
next
case Send thus ?case by (metis well_analyzed_singleton(2) well_analyzed_append)
next
case Equality thus ?case by (metis well_analyzed_singleton(3) well_analyzed_append)
next
case Inequality thus ?case by (metis well_analyzed_singleton(4) well_analyzed_append)
next
case (Decompose f T)
hence "Fun f T ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t 𝒜1 ∪ assignment_rhs⇩e⇩s⇩t 𝒜1) - (Var`𝒱)" by auto
thus ?case by (metis well_analyzed.Decomp Decompose.prems Decompose.hyps(3))
qed simp
qed metis
private lemma pts_symbolic_c_preserves_Ana_invar_subst:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')"
and "Ana_invar_subst (
(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮) ∪ (ik⇩e⇩s⇩t 𝒜)) ∪
(⋃(assignment_rhs⇩s⇩t ` 𝒮) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜)))"
shows "Ana_invar_subst (
(⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮') ∪ (ik⇩e⇩s⇩t 𝒜')) ∪
(⋃(assignment_rhs⇩s⇩t ` 𝒮') ∪ (assignment_rhs⇩e⇩s⇩t 𝒜')))"
using assms
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
from step.hyps(2) step.IH[OF step.prems] show ?case
proof (induction rule: pts_symbolic_c_induct)
case Nil
hence "⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮1) = ⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮2)"
"⋃(assignment_rhs⇩s⇩t ` 𝒮1) = ⋃(assignment_rhs⇩s⇩t ` 𝒮2)"
by force+
thus ?case using Nil by metis
next
case Send show ?case
using ik⇩s⇩t_update⇩s⇩t_subset_snd[OF Send.hyps]
Ana_invar_subst_subset[OF Send.prems]
by (metis Un_mono)
next
case Receive show ?case
using ik⇩s⇩t_update⇩s⇩t_subset_rcv[OF Receive.hyps]
Ana_invar_subst_subset[OF Receive.prems]
by (metis Un_mono)
next
case Equality show ?case
using ik⇩s⇩t_update⇩s⇩t_subset_eq[OF Equality.hyps]
Ana_invar_subst_subset[OF Equality.prems]
by (metis Un_mono)
next
case Inequality show ?case
using ik⇩s⇩t_update⇩s⇩t_subset_ineq[OF Inequality.hyps]
Ana_invar_subst_subset[OF Inequality.prems]
by (metis Un_mono)
next
case (Decompose f T)
let ?X = "⋃(assignment_rhs⇩s⇩t`𝒮2) ∪ assignment_rhs⇩e⇩s⇩t 𝒜2"
let ?Y = "⋃(assignment_rhs⇩s⇩t`𝒮1) ∪ assignment_rhs⇩e⇩s⇩t 𝒜1"
obtain K M where Ana: "Ana (Fun f T) = (K,M)" by moura
hence *: "ik⇩e⇩s⇩t 𝒜2 = ik⇩e⇩s⇩t 𝒜1 ∪ set M" "assignment_rhs⇩e⇩s⇩t 𝒜2 = assignment_rhs⇩e⇩s⇩t 𝒜1"
using ik⇩e⇩s⇩t_append assignment_rhs⇩e⇩s⇩t_append decomp_ik
decomp_assignment_rhs_empty Decompose.hyps(3)
by auto
{ fix g S assume "Fun g S ∈ subterms⇩s⇩e⇩t (⋃(ik⇩s⇩t`dual⇩s⇩t`𝒮2) ∪ ik⇩e⇩s⇩t 𝒜2 ∪ ?X)"
hence "Fun g S ∈ subterms⇩s⇩e⇩t (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮1) ∪ ik⇩e⇩s⇩t 𝒜1 ∪ set M ∪ ?X)"
using * Decompose.hyps(2) by auto
hence "Fun g S ∈ subterms⇩s⇩e⇩t (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮1))
∨ Fun g S ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t 𝒜1)
∨ Fun g S ∈ subterms⇩s⇩e⇩t (set M)
∨ Fun g S ∈ subterms⇩s⇩e⇩t (⋃(assignment_rhs⇩s⇩t`𝒮1))
∨ Fun g S ∈ subterms⇩s⇩e⇩t (assignment_rhs⇩e⇩s⇩t 𝒜1)"
using Decompose * Ana_fun_subterm[OF Ana] by auto
moreover have "Fun f T ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t 𝒜1 ∪ assignment_rhs⇩e⇩s⇩t 𝒜1)"
using trms⇩e⇩s⇩t_ik_subtermsI Decompose.hyps(1) by auto
hence "subterms (Fun f T) ⊆ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t 𝒜1 ∪ assignment_rhs⇩e⇩s⇩t 𝒜1)"
by (metis in_subterms_subset_Union)
hence "subterms⇩s⇩e⇩t (set M) ⊆ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t 𝒜1 ∪ assignment_rhs⇩e⇩s⇩t 𝒜1)"
by (meson Un_upper2 Ana_subterm[OF Ana] subterms_subset_set psubsetE subset_trans)
ultimately have "Fun g S ∈ subterms⇩s⇩e⇩t (⋃(ik⇩s⇩t`dual⇩s⇩t ` 𝒮1) ∪ ik⇩e⇩s⇩t 𝒜1 ∪ ?Y)"
by auto
}
thus ?case using Decompose unfolding Ana_invar_subst_def by metis
qed
qed
private lemma pts_symbolic_c_preserves_constr_disj_vars:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')" "wf⇩s⇩t⇩s' 𝒮 𝒜" "fv⇩e⇩s⇩t 𝒜 ∩ bvars⇩e⇩s⇩t 𝒜 = {}"
shows "fv⇩e⇩s⇩t 𝒜' ∩ bvars⇩e⇩s⇩t 𝒜' = {}"
using assms
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
have *: "⋀S. S ∈ 𝒮1 ⟹ fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t 𝒜1 = {}" "⋀S. S ∈ 𝒮1 ⟹ fv⇩e⇩s⇩t 𝒜1 ∩ bvars⇩s⇩t S = {}"
using pts_symbolic_c_preserves_wf_prot[OF step.hyps(1) step.prems(1)]
unfolding wf⇩s⇩t⇩s'_def by auto
from step.hyps(2) step.IH[OF step.prems]
show ?case
proof (induction rule: pts_symbolic_c_induct)
case Nil thus ?case by auto
next
case (Send t S)
hence "fv⇩e⇩s⇩t 𝒜2 = fv⇩e⇩s⇩t 𝒜1 ∪ fv t" "bvars⇩e⇩s⇩t 𝒜2 = bvars⇩e⇩s⇩t 𝒜1"
"fv⇩s⇩t (send⟨t⟩⇩s⇩t#S) = fv t ∪ fv⇩s⇩t S"
using fv⇩e⇩s⇩t_append bvars⇩e⇩s⇩t_append by simp+
thus ?case using *(1)[OF Send(1)] Send(4) by auto
next
case (Receive t S)
hence "fv⇩e⇩s⇩t 𝒜2 = fv⇩e⇩s⇩t 𝒜1 ∪ fv t" "bvars⇩e⇩s⇩t 𝒜2 = bvars⇩e⇩s⇩t 𝒜1"
"fv⇩s⇩t (receive⟨t⟩⇩s⇩t#S) = fv t ∪ fv⇩s⇩t S"
using fv⇩e⇩s⇩t_append bvars⇩e⇩s⇩t_append by simp+
thus ?case using *(1)[OF Receive(1)] Receive(4) by auto
next
case (Equality a t t' S)
hence "fv⇩e⇩s⇩t 𝒜2 = fv⇩e⇩s⇩t 𝒜1 ∪ fv t ∪ fv t'" "bvars⇩e⇩s⇩t 𝒜2 = bvars⇩e⇩s⇩t 𝒜1"
"fv⇩s⇩t (⟨a: t ≐ t'⟩⇩s⇩t#S) = fv t ∪ fv t' ∪ fv⇩s⇩t S"
using fv⇩e⇩s⇩t_append bvars⇩e⇩s⇩t_append by fastforce+
thus ?case using *(1)[OF Equality(1)] Equality(4) by auto
next
case (Inequality X F S)
hence "fv⇩e⇩s⇩t 𝒜2 = fv⇩e⇩s⇩t 𝒜1 ∪ (fv⇩p⇩a⇩i⇩r⇩s F - set X)" "bvars⇩e⇩s⇩t 𝒜2 = bvars⇩e⇩s⇩t 𝒜1 ∪ set X"
"fv⇩s⇩t (∀X⟨∨≠: F⟩⇩s⇩t#S) = (fv⇩p⇩a⇩i⇩r⇩s F - set X) ∪ fv⇩s⇩t S"
using fv⇩e⇩s⇩t_append bvars⇩e⇩s⇩t_append strand_vars_split(3)[of "[∀X⟨∨≠: F⟩⇩s⇩t]" S]
by auto+
moreover have "fv⇩e⇩s⇩t 𝒜1 ∩ set X = {}" using *(2)[OF Inequality(1)] by auto
ultimately show ?case using *(1)[OF Inequality(1)] Inequality(4) by auto
next
case (Decompose f T)
thus ?case
using Decompose(3,4) bvars_decomp ik_assignment_rhs_decomp_fv[OF Decompose(1)] by auto
qed
qed
subsubsection ‹Theorem: The Typing Result Lifted to the Transition System Level›
private lemma wf⇩s⇩t⇩s'_decomp_rm:
assumes "well_analyzed A" "wf⇩s⇩t⇩s' S (decomp_rm⇩e⇩s⇩t A)" shows "wf⇩s⇩t⇩s' S A"
unfolding wf⇩s⇩t⇩s'_def
proof (intro conjI)
show "∀S∈S. wf⇩s⇩t (wfrestrictedvars⇩e⇩s⇩t A) (dual⇩s⇩t S)"
by (metis (no_types) assms(2) wf⇩s⇩t⇩s'_def wfrestrictedvars⇩e⇩s⇩t_decomp_rm⇩e⇩s⇩t_subset
wf_vars_mono le_iff_sup)
show "∀Sa∈S. ∀S'∈S. fv⇩s⇩t Sa ∩ bvars⇩s⇩t S' = {}" by (metis assms(2) wf⇩s⇩t⇩s'_def)
show "∀S∈S. fv⇩s⇩t S ∩ bvars⇩e⇩s⇩t A = {}" by (metis assms(2) wf⇩s⇩t⇩s'_def bvars_decomp_rm)
show "∀S∈S. fv⇩e⇩s⇩t A ∩ bvars⇩s⇩t S = {}" by (metis assms wf⇩s⇩t⇩s'_def well_analyzed_decomp_rm⇩e⇩s⇩t_fv)
qed
private lemma decomps⇩e⇩s⇩t_pts_symbolic_c:
assumes "D ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t A) (assignment_rhs⇩e⇩s⇩t A) ℐ"
shows "(S,A) ⇒⇧∙⇩c⇧* (S,A@D)"
using assms(1)
proof (induction D rule: decomps⇩e⇩s⇩t.induct)
case (Decomp B f X K T)
have "subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t A ∪ assignment_rhs⇩e⇩s⇩t A) ⊆
subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t (A@B) ∪ assignment_rhs⇩e⇩s⇩t (A@B))"
using ik⇩e⇩s⇩t_append[of A B] assignment_rhs⇩e⇩s⇩t_append[of A B]
by auto
hence "Fun f X ∈ subterms⇩s⇩e⇩t (ik⇩e⇩s⇩t (A@B) ∪ assignment_rhs⇩e⇩s⇩t (A@B))" using Decomp.hyps by auto
hence "(S,A@B) ⇒⇧∙⇩c (S,A@B@[Decomp (Fun f X)])"
using pts_symbolic_c.Decompose[of f X "A@B"]
by simp
thus ?case
using Decomp.IH rtrancl_into_rtrancl
rtranclp_rtrancl_eq[of pts_symbolic_c "(S,A)" "(S,A@B)"]
by auto
qed simp
private lemma pts_symbolic_to_pts_symbolic_c:
assumes "(𝒮,to_st (decomp_rm⇩e⇩s⇩t 𝒜⇩d)) ⇒⇧∙⇧* (𝒮',𝒜')" "sem⇩e⇩s⇩t_d {} ℐ (to_est 𝒜')" "sem⇩e⇩s⇩t_c {} ℐ 𝒜⇩d"
and wf: "wf⇩s⇩t⇩s' 𝒮 (decomp_rm⇩e⇩s⇩t 𝒜⇩d)" "wf⇩e⇩s⇩t {} 𝒜⇩d"
and tar: "Ana_invar_subst ((⋃(ik⇩s⇩t` dual⇩s⇩t` 𝒮) ∪ (ik⇩e⇩s⇩t 𝒜⇩d))
∪ (⋃(assignment_rhs⇩s⇩t` 𝒮) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜⇩d)))"
and wa: "well_analyzed 𝒜⇩d"
and ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "∃𝒜⇩d'. 𝒜' = to_st (decomp_rm⇩e⇩s⇩t 𝒜⇩d') ∧ (𝒮,𝒜⇩d) ⇒⇧∙⇩c⇧* (𝒮',𝒜⇩d') ∧ sem⇩e⇩s⇩t_c {} ℐ 𝒜⇩d'"
using assms(1,2)
proof (induction rule: rtranclp_induct2)
case refl thus ?case using assms by auto
next
case (step 𝒮1 𝒜1 𝒮2 𝒜2)
have "sem⇩e⇩s⇩t_d {} ℐ (to_est 𝒜1)" using step.hyps(2) step.prems
by (induct rule: pts_symbolic_induct, metis, (metis sem⇩e⇩s⇩t_d_split_left to_est_append)+)
then obtain 𝒜1d where
𝒜1d: "𝒜1 = to_st (decomp_rm⇩e⇩s⇩t 𝒜1d)" "(𝒮, 𝒜⇩d) ⇒⇧∙⇩c⇧* (𝒮1, 𝒜1d)" "sem⇩e⇩s⇩t_c {} ℐ 𝒜1d"
using step.IH by moura
show ?case using step.hyps(2)
proof (induction rule: pts_symbolic_induct)
case Nil
hence "(𝒮, 𝒜⇩d) ⇒⇧∙⇩c⇧* (𝒮2, 𝒜1d)" using 𝒜1d pts_symbolic_c.Nil[OF Nil.hyps(1), of 𝒜1d] by simp
thus ?case using 𝒜1d Nil by auto
next
case (Send t S)
hence "sem⇩e⇩s⇩t_c {} ℐ (𝒜1d@[Step (receive⟨t⟩⇩s⇩t)])" using sem⇩e⇩s⇩t_c.Receive[OF 𝒜1d(3)] by simp
moreover have "(𝒮1, 𝒜1d) ⇒⇧∙⇩c (𝒮2, 𝒜1d@[Step (receive⟨t⟩⇩s⇩t)])"
using Send.hyps(2) pts_symbolic_c.Send[OF Send.hyps(1), of 𝒜1d] by simp
moreover have "to_st (decomp_rm⇩e⇩s⇩t (𝒜1d@[Step (receive⟨t⟩⇩s⇩t)])) = 𝒜2"
using Send.hyps(3) decomp_rm⇩e⇩s⇩t_append 𝒜1d(1) by (simp add: to_st_append)
ultimately show ?case using 𝒜1d(2) by auto
next
case (Equality a t t' S)
hence "t ⋅ ℐ = t' ⋅ ℐ"
using step.prems sem⇩e⇩s⇩t_d_eq_sem_st[of "{}" ℐ "to_est 𝒜2"]
to_st_append to_est_append to_st_to_est_inv
by auto
hence "sem⇩e⇩s⇩t_c {} ℐ (𝒜1d@[Step (⟨a: t ≐ t'⟩⇩s⇩t)])" using sem⇩e⇩s⇩t_c.Equality[OF 𝒜1d(3)] by simp
moreover have "(𝒮1, 𝒜1d) ⇒⇧∙⇩c (𝒮2, 𝒜1d@[Step (⟨a: t ≐ t'⟩⇩s⇩t)])"
using Equality.hyps(2) pts_symbolic_c.Equality[OF Equality.hyps(1), of 𝒜1d] by simp
moreover have "to_st (decomp_rm⇩e⇩s⇩t (𝒜1d@[Step (⟨a: t ≐ t'⟩⇩s⇩t)])) = 𝒜2"
using Equality.hyps(3) decomp_rm⇩e⇩s⇩t_append 𝒜1d(1) by (simp add: to_st_append)
ultimately show ?case using 𝒜1d(2) by auto
next
case (Inequality X F S)
hence "ineq_model ℐ X F"
using step.prems sem⇩e⇩s⇩t_d_eq_sem_st[of "{}" ℐ "to_est 𝒜2"]
to_st_append to_est_append to_st_to_est_inv
by auto
hence "sem⇩e⇩s⇩t_c {} ℐ (𝒜1d@[Step (∀X⟨∨≠: F⟩⇩s⇩t)])" using sem⇩e⇩s⇩t_c.Inequality[OF 𝒜1d(3)] by simp
moreover have "(𝒮1, 𝒜1d) ⇒⇧∙⇩c (𝒮2, 𝒜1d@[Step (∀X⟨∨≠: F⟩⇩s⇩t)])"
using Inequality.hyps(2) pts_symbolic_c.Inequality[OF Inequality.hyps(1), of 𝒜1d] by simp
moreover have "to_st (decomp_rm⇩e⇩s⇩t (𝒜1d@[Step (∀X⟨∨≠: F⟩⇩s⇩t)])) = 𝒜2"
using Inequality.hyps(3) decomp_rm⇩e⇩s⇩t_append 𝒜1d(1) by (simp add: to_st_append)
ultimately show ?case using 𝒜1d(2) by auto
next
case (Receive t S)
hence "ik⇩s⇩t 𝒜1 ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ"
using step.prems sem⇩e⇩s⇩t_d_eq_sem_st[of "{}" ℐ "to_est 𝒜2"]
strand_sem_split(4)[of "{}" 𝒜1 "[send⟨t⟩⇩s⇩t]" ℐ]
to_st_append to_est_append to_st_to_est_inv
by auto
moreover have "ik⇩s⇩t 𝒜1 ⋅⇩s⇩e⇩t ℐ ⊆ ik⇩e⇩s⇩t 𝒜1d ⋅⇩s⇩e⇩t ℐ" using 𝒜1d(1) decomp_rm⇩e⇩s⇩t_ik_subset by auto
ultimately have *: "ik⇩e⇩s⇩t 𝒜1d ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ" using ideduct_mono by auto
have "wf⇩s⇩t⇩s' 𝒮 𝒜⇩d" by (rule wf⇩s⇩t⇩s'_decomp_rm[OF wa assms(4)])
hence **: "wf⇩e⇩s⇩t {} 𝒜1d" by (rule pts_symbolic_c_preserves_wf_is[OF 𝒜1d(2) _ assms(5)])
have "Ana_invar_subst (⋃(ik⇩s⇩t`dual⇩s⇩t`𝒮1) ∪ (ik⇩e⇩s⇩t 𝒜1d) ∪
(⋃(assignment_rhs⇩s⇩t`𝒮1) ∪ (assignment_rhs⇩e⇩s⇩t 𝒜1d)))"
using tar 𝒜1d(2) pts_symbolic_c_preserves_Ana_invar_subst by metis
hence "Ana_invar_subst (ik⇩e⇩s⇩t 𝒜1d)" "Ana_invar_subst (assignment_rhs⇩e⇩s⇩t 𝒜1d)"
using Ana_invar_subst_subset by blast+
moreover have "well_analyzed 𝒜1d"
using pts_symbolic_c_preserves_well_analyzed[OF 𝒜1d(2) wa] by metis
ultimately obtain D where D:
"D ∈ decomps⇩e⇩s⇩t (ik⇩e⇩s⇩t 𝒜1d) (assignment_rhs⇩e⇩s⇩t 𝒜1d) ℐ"
"ik⇩e⇩s⇩t (𝒜1d@D) ⋅⇩s⇩e⇩t ℐ ⊢⇩c t ⋅ ℐ"
using decomps⇩e⇩s⇩t_exist_subst[OF * 𝒜1d(3) ** assms(8)] unfolding Ana_invar_subst_def by auto
have "(𝒮, 𝒜⇩d) ⇒⇧∙⇩c⇧* (𝒮1, 𝒜1d@D)" using 𝒜1d(2) decomps⇩e⇩s⇩t_pts_symbolic_c[OF D(1), of 𝒮1] by auto
hence "(𝒮, 𝒜⇩d) ⇒⇧∙⇩c⇧* (𝒮2, 𝒜1d@D@[Step (send⟨t⟩⇩s⇩t)])"
using Receive(2) pts_symbolic_c.Receive[OF Receive.hyps(1), of "𝒜1d@D"] by auto
moreover have "𝒜2 = to_st (decomp_rm⇩e⇩s⇩t (𝒜1d@D@[Step (send⟨t⟩⇩s⇩t)]))"
using Receive.hyps(3) 𝒜1d(1) decomps⇩e⇩s⇩t_decomp_rm⇩e⇩s⇩t_empty[OF D(1)]
decomp_rm⇩e⇩s⇩t_append to_st_append
by auto
moreover have "sem⇩e⇩s⇩t_c {} ℐ (𝒜1d@D@[Step (send⟨t⟩⇩s⇩t)])"
using D(2) sem⇩e⇩s⇩t_c.Send[OF sem⇩e⇩s⇩t_c_decomps⇩e⇩s⇩t_append[OF 𝒜1d(3) D(1)]] by simp
ultimately show ?case by auto
qed
qed
private lemma pts_symbolic_c_to_pts_symbolic:
assumes "(𝒮,𝒜) ⇒⇧∙⇩c⇧* (𝒮',𝒜')" "sem⇩e⇩s⇩t_c {} ℐ 𝒜'"
shows "(𝒮,to_st (decomp_rm⇩e⇩s⇩t 𝒜)) ⇒⇧∙⇧* (𝒮',to_st (decomp_rm⇩e⇩s⇩t 𝒜'))"
"sem⇩e⇩s⇩t_d {} ℐ (decomp_rm⇩e⇩s⇩t 𝒜')"
proof -
show "(𝒮,to_st (decomp_rm⇩e⇩s⇩t 𝒜)) ⇒⇧∙⇧* (𝒮',to_st (decomp_rm⇩e⇩s⇩t 𝒜'))" using assms(1)
proof (induction rule: rtranclp_induct2)
case (step 𝒮1 𝒜1 𝒮2 𝒜2) show ?case using step.hyps(2,1) step.IH
proof (induction rule: pts_symbolic_c_induct)
case Nil thus ?case
using pts_symbolic.Nil[OF Nil.hyps(1), of "to_st (decomp_rm⇩e⇩s⇩t 𝒜1)"] by simp
next
case (Send t S) thus ?case
using pts_symbolic.Send[OF Send.hyps(1), of "to_st (decomp_rm⇩e⇩s⇩t 𝒜1)"]
by (simp add: decomp_rm⇩e⇩s⇩t_append to_st_append)
next
case (Receive t S) thus ?case
using pts_symbolic.Receive[OF Receive.hyps(1), of "to_st (decomp_rm⇩e⇩s⇩t 𝒜1)"]
by (simp add: decomp_rm⇩e⇩s⇩t_append to_st_append)
next
case (Equality a t t' S) thus ?case
using pts_symbolic.Equality[OF Equality.hyps(1), of "to_st (decomp_rm⇩e⇩s⇩t 𝒜1)"]
by (simp add: decomp_rm⇩e⇩s⇩t_append to_st_append)
next
case (Inequality t t' S) thus ?case
using pts_symbolic.Inequality[OF Inequality.hyps(1), of "to_st (decomp_rm⇩e⇩s⇩t 𝒜1)"]
by (simp add: decomp_rm⇩e⇩s⇩t_append to_st_append)
next
case (Decompose t) thus ?case using decomp_rm⇩e⇩s⇩t_append by simp
qed
qed simp
qed (rule sem⇩e⇩s⇩t_d_decomp_rm⇩e⇩s⇩t_if_sem⇩e⇩s⇩t_c[OF assms(2)])
private lemma pts_symbolic_to_pts_symbolic_c_from_initial:
assumes "(𝒮⇩0,[]) ⇒⇧∙⇧* (𝒮,𝒜)" "ℐ ⊨ ⟨𝒜⟩" "wf⇩s⇩t⇩s' 𝒮⇩0 []"
and "Ana_invar_subst (⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮⇩0) ∪ ⋃(assignment_rhs⇩s⇩t ` 𝒮⇩0))" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "∃𝒜⇩d. 𝒜 = to_st (decomp_rm⇩e⇩s⇩t 𝒜⇩d) ∧ (𝒮⇩0,[]) ⇒⇧∙⇩c⇧* (𝒮,𝒜⇩d) ∧ (ℐ ⊨⇩c ⟨to_st 𝒜⇩d⟩)"
using assms pts_symbolic_to_pts_symbolic_c[of 𝒮⇩0 "[]" 𝒮 𝒜 ℐ]
sem⇩e⇩s⇩t_c_eq_sem_st[of "{}" ℐ] sem⇩e⇩s⇩t_d_eq_sem_st[of "{}" ℐ]
to_st_to_est_inv[of 𝒜] strand_sem_eq_defs
by (auto simp add: constr_sem_c_def constr_sem_d_def simp del: subst_range.simps)
private lemma pts_symbolic_c_to_pts_symbolic_from_initial:
assumes "(𝒮⇩0,[]) ⇒⇧∙⇩c⇧* (𝒮,𝒜)" "ℐ ⊨⇩c ⟨to_st 𝒜⟩"
shows "(𝒮⇩0,[]) ⇒⇧∙⇧* (𝒮,to_st (decomp_rm⇩e⇩s⇩t 𝒜))" "ℐ ⊨ ⟨to_st (decomp_rm⇩e⇩s⇩t 𝒜)⟩"
using assms pts_symbolic_c_to_pts_symbolic[of 𝒮⇩0 "[]" 𝒮 𝒜 ℐ]
sem⇩e⇩s⇩t_c_eq_sem_st[of "{}" ℐ] sem⇩e⇩s⇩t_d_eq_sem_st[of "{}" ℐ] strand_sem_eq_defs
by (auto simp add: constr_sem_c_def constr_sem_d_def)
private lemma to_st_trms_wf:
assumes "wf⇩t⇩r⇩m⇩s (trms⇩e⇩s⇩t A)"
shows "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t (to_st A))"
using assms
proof (induction A)
case (Cons x A)
hence IH: "∀t ∈ trms⇩s⇩t (to_st A). wf⇩t⇩r⇩m t" by auto
with Cons show ?case
proof (cases x)
case (Decomp t)
hence "wf⇩t⇩r⇩m t" using Cons.prems by auto
obtain K T where Ana_t: "Ana t = (K,T)" by moura
hence "trms⇩s⇩t (decomp t) ⊆ {t} ∪ set K ∪ set T" using decomp_set_unfold[OF Ana_t] by force
moreover have "∀t ∈ set T. wf⇩t⇩r⇩m t" using Ana_subterm[OF Ana_t] ‹wf⇩t⇩r⇩m t› wf_trm_subterm by auto
ultimately have "∀t ∈ trms⇩s⇩t (decomp t). wf⇩t⇩r⇩m t" using Ana_keys_wf'[OF Ana_t] ‹wf⇩t⇩r⇩m t› by auto
thus ?thesis using IH Decomp by auto
qed auto
qed simp
private lemma to_st_trms_SMP_subset: "trms⇩s⇩t (to_st A) ⊆ SMP (trms⇩e⇩s⇩t A)"
proof
fix t assume "t ∈ trms⇩s⇩t (to_st A)" thus "t ∈ SMP (trms⇩e⇩s⇩t A)"
proof (induction A)
case (Cons x A)
hence *: "t ∈ trms⇩s⇩t (to_st [x]) ∪ trms⇩s⇩t (to_st A)" using to_st_append[of "[x]" A] by auto
have **: "trms⇩s⇩t (to_st A) ⊆ trms⇩s⇩t (to_st (x#A))" "trms⇩e⇩s⇩t A ⊆ trms⇩e⇩s⇩t (x#A)"
using to_st_append[of "[x]" A] by auto
show ?case
proof (cases "t ∈ trms⇩s⇩t (to_st A)")
case True thus ?thesis using Cons.IH SMP_mono[OF **(2)] by auto
next
case False
hence ***: "t ∈ trms⇩s⇩t (to_st [x])" using * by auto
thus ?thesis
proof (cases x)
case (Decomp t')
hence ****: "t ∈ trms⇩s⇩t (decomp t')" "t' ∈ trms⇩e⇩s⇩t (x#A)" using *** by auto
obtain K T where Ana_t': "Ana t' = (K,T)" by moura
hence "t ∈ {t'} ∪ set K ∪ set T" using decomp_set_unfold[OF Ana_t'] ****(1) by force
moreover
{ assume "t = t'" hence ?thesis using SMP.MP[OF ****(2)] by simp }
moreover
{ assume "t ∈ set K" hence ?thesis using SMP.Ana[OF SMP.MP[OF ****(2)] Ana_t'] by auto }
moreover
{ assume "t ∈ set T" "t ≠ t'"
hence "t ⊏ t'" using Ana_subterm[OF Ana_t'] by blast
hence ?thesis using SMP.Subterm[OF SMP.MP[OF ****(2)]] by auto
}
ultimately show ?thesis using Decomp by auto
qed auto
qed
qed simp
qed
private lemma to_st_trms_tfr⇩s⇩e⇩t:
assumes "tfr⇩s⇩e⇩t (trms⇩e⇩s⇩t A)"
shows "tfr⇩s⇩e⇩t (trms⇩s⇩t (to_st A))"
proof -
have *: "trms⇩s⇩t (to_st A) ⊆ SMP (trms⇩e⇩s⇩t A)"
using to_st_trms_wf to_st_trms_SMP_subset assms unfolding tfr⇩s⇩e⇩t_def by auto
have "trms⇩s⇩t (to_st A) = trms⇩s⇩t (to_st A) ∪ trms⇩e⇩s⇩t A" by (blast dest!: trms⇩e⇩s⇩tD)
hence "SMP (trms⇩e⇩s⇩t A) = SMP (trms⇩s⇩t (to_st A))" using SMP_subset_union_eq[OF *] by auto
thus ?thesis using * assms unfolding tfr⇩s⇩e⇩t_def by presburger
qed
theorem wt_attack_if_tfr_attack_pts:
assumes "wf⇩s⇩t⇩s 𝒮⇩0" "tfr⇩s⇩e⇩t (⋃(trms⇩s⇩t ` 𝒮⇩0))" "wf⇩t⇩r⇩m⇩s (⋃(trms⇩s⇩t ` 𝒮⇩0))" "∀S ∈ 𝒮⇩0. list_all tfr⇩s⇩t⇩p S"
and "Ana_invar_subst (⋃(ik⇩s⇩t ` dual⇩s⇩t ` 𝒮⇩0) ∪ ⋃(assignment_rhs⇩s⇩t ` 𝒮⇩0))"
and "(𝒮⇩0,[]) ⇒⇧∙⇧* (𝒮,𝒜)" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "ℐ ⊨ ⟨𝒜, Var⟩"
shows "∃ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ (ℐ⇩τ ⊨ ⟨𝒜, Var⟩) ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
proof -
have "(⋃(trms⇩s⇩t ` 𝒮⇩0)) ∪ (trms⇩e⇩s⇩t []) = ⋃(trms⇩s⇩t ` 𝒮⇩0)" "to_st [] = []" "list_all tfr⇩s⇩t⇩p []"
using assms by simp_all
hence *: "tfr⇩s⇩e⇩t ((⋃(trms⇩s⇩t ` 𝒮⇩0)) ∪ (trms⇩e⇩s⇩t []))"
"wf⇩t⇩r⇩m⇩s ((⋃(trms⇩s⇩t ` 𝒮⇩0)) ∪ (trms⇩e⇩s⇩t []))"
"wf⇩s⇩t⇩s' 𝒮⇩0 []" "∀S ∈ 𝒮⇩0 ∪ {to_st []}. list_all tfr⇩s⇩t⇩p S"
using assms wf⇩s⇩t⇩s_wf⇩s⇩t⇩s' by (metis, metis, metis, simp)
obtain 𝒜⇩d where 𝒜⇩d: "𝒜 = to_st (decomp_rm⇩e⇩s⇩t 𝒜⇩d)" "(𝒮⇩0,[]) ⇒⇧∙⇩c⇧* (𝒮,𝒜⇩d)" "ℐ ⊨⇩c ⟨to_st 𝒜⇩d⟩"
using pts_symbolic_to_pts_symbolic_c_from_initial assms *(3) by metis
hence "tfr⇩s⇩e⇩t (⋃(trms⇩s⇩t ` 𝒮) ∪ (trms⇩e⇩s⇩t 𝒜⇩d))" "wf⇩t⇩r⇩m⇩s (⋃(trms⇩s⇩t ` 𝒮) ∪ (trms⇩e⇩s⇩t 𝒜⇩d))"
using pts_symbolic_c_preserves_tfr⇩s⇩e⇩t[OF _ *(1,2)] by blast+
hence "tfr⇩s⇩e⇩t (trms⇩e⇩s⇩t 𝒜⇩d)" "wf⇩t⇩r⇩m⇩s (trms⇩e⇩s⇩t 𝒜⇩d)"
unfolding tfr⇩s⇩e⇩t_def by (metis DiffE DiffI SMP_union UnCI, metis UnCI)
hence "tfr⇩s⇩e⇩t (trms⇩s⇩t (to_st 𝒜⇩d))" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t (to_st 𝒜⇩d))"
by (metis to_st_trms_tfr⇩s⇩e⇩t, metis to_st_trms_wf)
moreover have "wf⇩c⇩o⇩n⇩s⇩t⇩r (to_st 𝒜⇩d) Var"
proof -
have "wt⇩s⇩u⇩b⇩s⇩t Var" "wf⇩t⇩r⇩m⇩s (subst_range Var)" "subst_domain Var ∩ vars⇩e⇩s⇩t 𝒜⇩d = {}"
"range_vars Var ∩ bvars⇩e⇩s⇩t 𝒜⇩d = {}"
by (simp_all add: range_vars_alt_def)
moreover have "wf⇩e⇩s⇩t {} 𝒜⇩d"
using pts_symbolic_c_preserves_wf_is[OF 𝒜⇩d(2) *(3), of "{}"]
by auto
moreover have "fv⇩s⇩t (to_st 𝒜⇩d) ∩ bvars⇩e⇩s⇩t 𝒜⇩d = {}"
using pts_symbolic_c_preserves_constr_disj_vars[OF 𝒜⇩d(2)] assms(1) wf⇩s⇩t⇩s_wf⇩s⇩t⇩s'
by fastforce
ultimately show ?thesis unfolding wf⇩c⇩o⇩n⇩s⇩t⇩r_def wf⇩s⇩u⇩b⇩s⇩t_def by simp
qed
moreover have "list_all tfr⇩s⇩t⇩p (to_st 𝒜⇩d)"
using pts_symbolic_c_preserves_tfr⇩s⇩t⇩p[OF 𝒜⇩d(2) *(4)] by blast
moreover have "wt⇩s⇩u⇩b⇩s⇩t Var" "wf⇩t⇩r⇩m⇩s (subst_range Var)" by simp_all
ultimately obtain ℐ⇩τ where ℐ⇩τ:
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "ℐ⇩τ ⊨⇩c ⟨to_st 𝒜⇩d, Var⟩" "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
using wt_attack_if_tfr_attack[OF assms(7) 𝒜⇩d(3)]
‹tfr⇩s⇩e⇩t (trms⇩s⇩t (to_st 𝒜⇩d))› ‹list_all tfr⇩s⇩t⇩p (to_st 𝒜⇩d)›
unfolding tfr⇩s⇩t_def by metis
hence "ℐ⇩τ ⊨ ⟨𝒜, Var⟩" using pts_symbolic_c_to_pts_symbolic_from_initial 𝒜⇩d by metis
thus ?thesis using ℐ⇩τ(1,3,4) by metis
qed
subsubsection ‹Corollary: The Typing Result on the Level of Constraints›
text ‹There exists well-typed models of satisfiable type-flaw resistant constraints›
corollary wt_attack_if_tfr_attack_d:
assumes "wf⇩s⇩t {} 𝒜" "fv⇩s⇩t 𝒜 ∩ bvars⇩s⇩t 𝒜 = {}" "tfr⇩s⇩t 𝒜" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t 𝒜)"
and "Ana_invar_subst (ik⇩s⇩t 𝒜 ∪ assignment_rhs⇩s⇩t 𝒜)"
and "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "ℐ ⊨ ⟨𝒜⟩"
shows "∃ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ (ℐ⇩τ ⊨ ⟨𝒜⟩) ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
proof -
{ fix S A have "({S},A) ⇒⇧∙⇧* ({},A@dual⇩s⇩t S)"
proof (induction S arbitrary: A)
case Nil thus ?case using pts_symbolic.Nil[of "{[]}"] by auto
next
case (Cons x S)
hence "({S}, A@dual⇩s⇩t [x]) ⇒⇧∙⇧* ({}, A@dual⇩s⇩t (x#S))"
by (metis dual⇩s⇩t_append List.append_assoc List.append_Nil List.append_Cons)
moreover have "({x#S}, A) ⇒⇧∙ ({S}, A@dual⇩s⇩t [x])"
using pts_symbolic.Send[of _ S "{x#S}"] pts_symbolic.Receive[of _ S "{x#S}"]
pts_symbolic.Equality[of _ _ _ S "{x#S}"] pts_symbolic.Inequality[of _ _ S "{x#S}"]
by (cases x) auto
ultimately show ?case by simp
qed
}
hence 0: "({dual⇩s⇩t 𝒜},[]) ⇒⇧∙⇧* ({},𝒜)" using dual⇩s⇩t_self_inverse by (metis List.append_Nil)
have "fv⇩s⇩t (dual⇩s⇩t 𝒜) ∩ bvars⇩s⇩t (dual⇩s⇩t 𝒜) = {}" using assms(2) dual⇩s⇩t_fv dual⇩s⇩t_bvars by metis+
hence 1: "wf⇩s⇩t⇩s {dual⇩s⇩t 𝒜}" using assms(1,2) dual⇩s⇩t_self_inverse[of 𝒜] unfolding wf⇩s⇩t⇩s_def by auto
have "⋃(trms⇩s⇩t ` {𝒜}) = trms⇩s⇩t 𝒜" "⋃(trms⇩s⇩t ` {dual⇩s⇩t 𝒜}) = trms⇩s⇩t (dual⇩s⇩t 𝒜)" by auto
hence "tfr⇩s⇩e⇩t (⋃(trms⇩s⇩t ` {𝒜}))" "wf⇩t⇩r⇩m⇩s (⋃(trms⇩s⇩t ` {𝒜}))"
"(⋃(trms⇩s⇩t ` {𝒜})) = ⋃(trms⇩s⇩t ` {dual⇩s⇩t 𝒜})"
using assms(3,4) unfolding tfr⇩s⇩t_def
by (metis, metis, metis dual⇩s⇩t_trms_eq)
hence 2: "tfr⇩s⇩e⇩t (⋃(trms⇩s⇩t ` {dual⇩s⇩t 𝒜}))" and 3: "wf⇩t⇩r⇩m⇩s (⋃(trms⇩s⇩t ` {dual⇩s⇩t 𝒜}))" by metis+
have 4: "∀S ∈ {dual⇩s⇩t 𝒜}. list_all tfr⇩s⇩t⇩p S"
using dual⇩s⇩t_tfr⇩s⇩t⇩p assms(3) unfolding tfr⇩s⇩t_def by blast
have "assignment_rhs⇩s⇩t 𝒜 = assignment_rhs⇩s⇩t (dual⇩s⇩t 𝒜)"
by (induct 𝒜 rule: assignment_rhs⇩s⇩t.induct) auto
hence 5: "Ana_invar_subst (⋃(ik⇩s⇩t`dual⇩s⇩t`{dual⇩s⇩t 𝒜}) ∪ ⋃(assignment_rhs⇩s⇩t`{dual⇩s⇩t 𝒜}))"
using assms(5) dual⇩s⇩t_self_inverse[of 𝒜] by auto
show ?thesis by (rule wt_attack_if_tfr_attack_pts[OF 1 2 3 4 5 0 assms(6,7)])
qed
end
end
end
Theory Stateful_Strands
section ‹Stateful Strands›
theory Stateful_Strands
imports Strands_and_Constraints
begin
subsection ‹Stateful Constraints›
datatype (funs⇩s⇩s⇩t⇩p: 'a, vars⇩s⇩s⇩t⇩p: 'b) stateful_strand_step =
Send (the_msg: "('a,'b) term") ("send⟨_⟩" 80)
| Receive (the_msg: "('a,'b) term") ("receive⟨_⟩" 80)
| Equality (the_check: poscheckvariant) (the_lhs: "('a,'b) term") (the_rhs: "('a,'b) term")
("⟨_: _ ≐ _⟩" [80,80])
| Insert (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term") ("insert⟨_,_⟩" 80)
| Delete (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term") ("delete⟨_,_⟩" 80)
| InSet (the_check: poscheckvariant) (the_elem_term: "('a,'b) term") (the_set_term: "('a,'b) term")
("⟨_: _ ∈ _⟩" [80,80])
| NegChecks (bvars⇩s⇩s⇩t⇩p: "'b list")
(the_eqs: "(('a,'b) term × ('a,'b) term) list")
(the_ins: "(('a,'b) term × ('a,'b) term) list")
("∀_⟨∨≠: _ ∨∉: _⟩" [80,80])
where
"bvars⇩s⇩s⇩t⇩p (Send _) = []"
| "bvars⇩s⇩s⇩t⇩p (Receive _) = []"
| "bvars⇩s⇩s⇩t⇩p (Equality _ _ _) = []"
| "bvars⇩s⇩s⇩t⇩p (Insert _ _) = []"
| "bvars⇩s⇩s⇩t⇩p (Delete _ _) = []"
| "bvars⇩s⇩s⇩t⇩p (InSet _ _ _) = []"
type_synonym ('a,'b) stateful_strand = "('a,'b) stateful_strand_step list"
type_synonym ('a,'b) dbstatelist = "(('a,'b) term × ('a,'b) term) list"
type_synonym ('a,'b) dbstate = "(('a,'b) term × ('a,'b) term) set"
abbreviation
"is_Assignment x ≡ (is_Equality x ∨ is_InSet x) ∧ the_check x = Assign"
abbreviation
"is_Check x ≡ ((is_Equality x ∨ is_InSet x) ∧ the_check x = Check) ∨ is_NegChecks x"
abbreviation
"is_Update x ≡ is_Insert x ∨ is_Delete x"
abbreviation InSet_select ("select⟨_,_⟩") where "select⟨t,s⟩ ≡ InSet Assign t s"
abbreviation InSet_check ("⟨_ in _⟩") where "⟨t in s⟩ ≡ InSet Check t s"
abbreviation Equality_assign ("⟨_ := _⟩") where "⟨t := s⟩ ≡ Equality Assign t s"
abbreviation Equality_check ("⟨_ == _⟩") where "⟨t == s⟩ ≡ Equality Check t s"
abbreviation NegChecks_Inequality1 ("⟨_ != _⟩") where
"⟨t != s⟩ ≡ NegChecks [] [(t,s)] []"
abbreviation NegChecks_Inequality2 ("∀_⟨_ != _⟩") where
"∀x⟨t != s⟩ ≡ NegChecks [x] [(t,s)] []"
abbreviation NegChecks_Inequality3 ("∀_,_⟨_ != _⟩") where
"∀x,y⟨t != s⟩ ≡ NegChecks [x,y] [(t,s)] []"
abbreviation NegChecks_Inequality4 ("∀_,_,_⟨_ != _⟩") where
"∀x,y,z⟨t != s⟩ ≡ NegChecks [x,y,z] [(t,s)] []"
abbreviation NegChecks_NotInSet1 ("⟨_ not in _⟩") where
"⟨t not in s⟩ ≡ NegChecks [] [] [(t,s)]"
abbreviation NegChecks_NotInSet2 ("∀_⟨_ not in _⟩") where
"∀x⟨t not in s⟩ ≡ NegChecks [x] [] [(t,s)]"
abbreviation NegChecks_NotInSet3 ("∀_,_⟨_ not in _⟩") where
"∀x,y⟨t not in s⟩ ≡ NegChecks [x,y] [] [(t,s)]"
abbreviation NegChecks_NotInSet4 ("∀_,_,_⟨_ not in _⟩") where
"∀x,y,z⟨t not in s⟩ ≡ NegChecks [x,y,z] [] [(t,s)]"
fun trms⇩s⇩s⇩t⇩p where
"trms⇩s⇩s⇩t⇩p (Send t) = {t}"
| "trms⇩s⇩s⇩t⇩p (Receive t) = {t}"
| "trms⇩s⇩s⇩t⇩p (Equality _ t t') = {t,t'}"
| "trms⇩s⇩s⇩t⇩p (Insert t t') = {t,t'}"
| "trms⇩s⇩s⇩t⇩p (Delete t t') = {t,t'}"
| "trms⇩s⇩s⇩t⇩p (InSet _ t t') = {t,t'}"
| "trms⇩s⇩s⇩t⇩p (NegChecks _ F F') = trms⇩p⇩a⇩i⇩r⇩s F ∪ trms⇩p⇩a⇩i⇩r⇩s F'"
definition trms⇩s⇩s⇩t where "trms⇩s⇩s⇩t S ≡ ⋃(trms⇩s⇩s⇩t⇩p ` set S)"
declare trms⇩s⇩s⇩t_def[simp]
fun trms_list⇩s⇩s⇩t⇩p where
"trms_list⇩s⇩s⇩t⇩p (Send t) = [t]"
| "trms_list⇩s⇩s⇩t⇩p (Receive t) = [t]"
| "trms_list⇩s⇩s⇩t⇩p (Equality _ t t') = [t,t']"
| "trms_list⇩s⇩s⇩t⇩p (Insert t t') = [t,t']"
| "trms_list⇩s⇩s⇩t⇩p (Delete t t') = [t,t']"
| "trms_list⇩s⇩s⇩t⇩p (InSet _ t t') = [t,t']"
| "trms_list⇩s⇩s⇩t⇩p (NegChecks _ F F') = concat (map (λ(t,t'). [t,t']) (F@F'))"
definition trms_list⇩s⇩s⇩t where "trms_list⇩s⇩s⇩t S ≡ remdups (concat (map trms_list⇩s⇩s⇩t⇩p S))"
definition ik⇩s⇩s⇩t where "ik⇩s⇩s⇩t A ≡ {t. Receive t ∈ set A}"
definition bvars⇩s⇩s⇩t::"('a,'b) stateful_strand ⇒ 'b set" where
"bvars⇩s⇩s⇩t S ≡ ⋃(set (map (set ∘ bvars⇩s⇩s⇩t⇩p) S))"
fun fv⇩s⇩s⇩t⇩p::"('a,'b) stateful_strand_step ⇒ 'b set" where
"fv⇩s⇩s⇩t⇩p (Send t) = fv t"
| "fv⇩s⇩s⇩t⇩p (Receive t) = fv t"
| "fv⇩s⇩s⇩t⇩p (Equality _ t t') = fv t ∪ fv t'"
| "fv⇩s⇩s⇩t⇩p (Insert t t') = fv t ∪ fv t'"
| "fv⇩s⇩s⇩t⇩p (Delete t t') = fv t ∪ fv t'"
| "fv⇩s⇩s⇩t⇩p (InSet _ t t') = fv t ∪ fv t'"
| "fv⇩s⇩s⇩t⇩p (NegChecks X F F') = fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s F' - set X"
definition fv⇩s⇩s⇩t::"('a,'b) stateful_strand ⇒ 'b set" where
"fv⇩s⇩s⇩t S ≡ ⋃(set (map fv⇩s⇩s⇩t⇩p S))"
fun fv_list⇩s⇩s⇩t⇩p where
"fv_list⇩s⇩s⇩t⇩p (send⟨t⟩) = fv_list t"
| "fv_list⇩s⇩s⇩t⇩p (receive⟨t⟩) = fv_list t"
| "fv_list⇩s⇩s⇩t⇩p (⟨_: t ≐ s⟩) = fv_list t@fv_list s"
| "fv_list⇩s⇩s⇩t⇩p (insert⟨t,s⟩) = fv_list t@fv_list s"
| "fv_list⇩s⇩s⇩t⇩p (delete⟨t,s⟩) = fv_list t@fv_list s"
| "fv_list⇩s⇩s⇩t⇩p (⟨_: t ∈ s⟩) = fv_list t@fv_list s"
| "fv_list⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: F'⟩) = filter (λx. x ∉ set X) (fv_list⇩p⇩a⇩i⇩r⇩s (F@F'))"
definition fv_list⇩s⇩s⇩t where
"fv_list⇩s⇩s⇩t S ≡ remdups (concat (map fv_list⇩s⇩s⇩t⇩p S))"
declare bvars⇩s⇩s⇩t_def[simp]
declare fv⇩s⇩s⇩t_def[simp]
definition vars⇩s⇩s⇩t::"('a,'b) stateful_strand ⇒ 'b set" where
"vars⇩s⇩s⇩t S ≡ ⋃(set (map vars⇩s⇩s⇩t⇩p S))"
abbreviation wfrestrictedvars⇩s⇩s⇩t⇩p::"('a,'b) stateful_strand_step ⇒ 'b set" where
"wfrestrictedvars⇩s⇩s⇩t⇩p x ≡
case x of
NegChecks _ _ _ ⇒ {}
| Equality Check _ _ ⇒ {}
| InSet Check _ _ ⇒ {}
| Delete _ _ ⇒ {}
| _ ⇒ vars⇩s⇩s⇩t⇩p x"
definition wfrestrictedvars⇩s⇩s⇩t::"('a,'b) stateful_strand ⇒ 'b set" where
"wfrestrictedvars⇩s⇩s⇩t S ≡ ⋃(set (map wfrestrictedvars⇩s⇩s⇩t⇩p S))"
abbreviation wfvarsoccs⇩s⇩s⇩t⇩p where
"wfvarsoccs⇩s⇩s⇩t⇩p x ≡
case x of
Send t ⇒ fv t
| Equality Assign s t ⇒ fv s
| InSet Assign s t ⇒ fv s ∪ fv t
| _ ⇒ {}"
definition wfvarsoccs⇩s⇩s⇩t where
"wfvarsoccs⇩s⇩s⇩t S ≡ ⋃(set (map wfvarsoccs⇩s⇩s⇩t⇩p S))"
fun wf'⇩s⇩s⇩t::"'b set ⇒ ('a,'b) stateful_strand ⇒ bool" where
"wf'⇩s⇩s⇩t V [] = True"
| "wf'⇩s⇩s⇩t V (Receive t#S) = (fv t ⊆ V ∧ wf'⇩s⇩s⇩t V S)"
| "wf'⇩s⇩s⇩t V (Send t#S) = wf'⇩s⇩s⇩t (V ∪ fv t) S"
| "wf'⇩s⇩s⇩t V (Equality Assign t t'#S) = (fv t' ⊆ V ∧ wf'⇩s⇩s⇩t (V ∪ fv t) S)"
| "wf'⇩s⇩s⇩t V (Equality Check _ _#S) = wf'⇩s⇩s⇩t V S"
| "wf'⇩s⇩s⇩t V (Insert t s#S) = (fv t ⊆ V ∧ fv s ⊆ V ∧ wf'⇩s⇩s⇩t V S)"
| "wf'⇩s⇩s⇩t V (Delete _ _#S) = wf'⇩s⇩s⇩t V S"
| "wf'⇩s⇩s⇩t V (InSet Assign t s#S) = wf'⇩s⇩s⇩t (V ∪ fv t ∪ fv s) S"
| "wf'⇩s⇩s⇩t V (InSet Check _ _#S) = wf'⇩s⇩s⇩t V S"
| "wf'⇩s⇩s⇩t V (NegChecks _ _ _#S) = wf'⇩s⇩s⇩t V S"
abbreviation "wf⇩s⇩s⇩t S ≡ wf'⇩s⇩s⇩t {} S ∧ fv⇩s⇩s⇩t S ∩ bvars⇩s⇩s⇩t S = {}"
fun subst_apply_stateful_strand_step::
"('a,'b) stateful_strand_step ⇒ ('a,'b) subst ⇒ ('a,'b) stateful_strand_step"
(infix "⋅⇩s⇩s⇩t⇩p" 51) where
"send⟨t⟩ ⋅⇩s⇩s⇩t⇩p θ = send⟨t ⋅ θ⟩"
| "receive⟨t⟩ ⋅⇩s⇩s⇩t⇩p θ = receive⟨t ⋅ θ⟩"
| "⟨a: t ≐ s⟩ ⋅⇩s⇩s⇩t⇩p θ = ⟨a: (t ⋅ θ) ≐ (s ⋅ θ)⟩"
| "⟨a: t ∈ s⟩ ⋅⇩s⇩s⇩t⇩p θ = ⟨a: (t ⋅ θ) ∈ (s ⋅ θ)⟩"
| "insert⟨t,s⟩ ⋅⇩s⇩s⇩t⇩p θ = insert⟨t ⋅ θ, s ⋅ θ⟩"
| "delete⟨t,s⟩ ⋅⇩s⇩s⇩t⇩p θ = delete⟨t ⋅ θ, s ⋅ θ⟩"
| "∀X⟨∨≠: F ∨∉: G⟩ ⋅⇩s⇩s⇩t⇩p θ = ∀X⟨∨≠: (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∨∉: (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)⟩"
definition subst_apply_stateful_strand::
"('a,'b) stateful_strand ⇒ ('a,'b) subst ⇒ ('a,'b) stateful_strand"
(infix "⋅⇩s⇩s⇩t" 51) where
"S ⋅⇩s⇩s⇩t θ ≡ map (λx. x ⋅⇩s⇩s⇩t⇩p θ) S"
fun dbupd⇩s⇩s⇩t::"('f,'v) stateful_strand ⇒ ('f,'v) subst ⇒ ('f,'v) dbstate ⇒ ('f,'v) dbstate"
where
"dbupd⇩s⇩s⇩t [] I D = D"
| "dbupd⇩s⇩s⇩t (Insert t s#A) I D = dbupd⇩s⇩s⇩t A I (insert ((t,s) ⋅⇩p I) D)"
| "dbupd⇩s⇩s⇩t (Delete t s#A) I D = dbupd⇩s⇩s⇩t A I (D - {((t,s) ⋅⇩p I)})"
| "dbupd⇩s⇩s⇩t (_#A) I D = dbupd⇩s⇩s⇩t A I D"
fun db'⇩s⇩s⇩t::"('f,'v) stateful_strand ⇒ ('f,'v) subst ⇒ ('f,'v) dbstatelist ⇒ ('f,'v) dbstatelist"
where
"db'⇩s⇩s⇩t [] I D = D"
| "db'⇩s⇩s⇩t (Insert t s#A) I D = db'⇩s⇩s⇩t A I (List.insert ((t,s) ⋅⇩p I) D)"
| "db'⇩s⇩s⇩t (Delete t s#A) I D = db'⇩s⇩s⇩t A I (List.removeAll ((t,s) ⋅⇩p I) D)"
| "db'⇩s⇩s⇩t (_#A) I D = db'⇩s⇩s⇩t A I D"
definition db⇩s⇩s⇩t where
"db⇩s⇩s⇩t S I ≡ db'⇩s⇩s⇩t S I []"
fun setops⇩s⇩s⇩t⇩p where
"setops⇩s⇩s⇩t⇩p (Insert t s) = {(t,s)}"
| "setops⇩s⇩s⇩t⇩p (Delete t s) = {(t,s)}"
| "setops⇩s⇩s⇩t⇩p (InSet _ t s) = {(t,s)}"
| "setops⇩s⇩s⇩t⇩p (NegChecks _ _ F') = set F'"
| "setops⇩s⇩s⇩t⇩p _ = {}"
text ‹The set-operations of a stateful strand›
definition setops⇩s⇩s⇩t where
"setops⇩s⇩s⇩t S ≡ ⋃(setops⇩s⇩s⇩t⇩p ` set S)"
fun setops_list⇩s⇩s⇩t⇩p where
"setops_list⇩s⇩s⇩t⇩p (Insert t s) = [(t,s)]"
| "setops_list⇩s⇩s⇩t⇩p (Delete t s) = [(t,s)]"
| "setops_list⇩s⇩s⇩t⇩p (InSet _ t s) = [(t,s)]"
| "setops_list⇩s⇩s⇩t⇩p (NegChecks _ _ F') = F'"
| "setops_list⇩s⇩s⇩t⇩p _ = []"
text ‹The set-operations of a stateful strand (list variant)›
definition setops_list⇩s⇩s⇩t where
"setops_list⇩s⇩s⇩t S ≡ remdups (concat (map setops_list⇩s⇩s⇩t⇩p S))"
subsection ‹Small Lemmata›
lemma trms_list⇩s⇩s⇩t_is_trms⇩s⇩s⇩t: "trms⇩s⇩s⇩t S = set (trms_list⇩s⇩s⇩t S)"
unfolding trms⇩s⇩t_def trms_list⇩s⇩s⇩t_def
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
lemma setops_list⇩s⇩s⇩t_is_setops⇩s⇩s⇩t: "setops⇩s⇩s⇩t S = set (setops_list⇩s⇩s⇩t S)"
unfolding setops⇩s⇩s⇩t_def setops_list⇩s⇩s⇩t_def
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
lemma fv_list⇩s⇩s⇩t⇩p_is_fv⇩s⇩s⇩t⇩p: "fv⇩s⇩s⇩t⇩p a = set (fv_list⇩s⇩s⇩t⇩p a)"
proof (cases a)
case (NegChecks X F G) thus ?thesis
using fv⇩p⇩a⇩i⇩r⇩s_append[of F G] fv_list⇩p⇩a⇩i⇩r⇩s_append[of F G]
fv_list⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s[of "F@G"]
by auto
qed (simp_all add: fv_list⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s fv_list_is_fv)
lemma fv_list⇩s⇩s⇩t_is_fv⇩s⇩s⇩t: "fv⇩s⇩s⇩t S = set (fv_list⇩s⇩s⇩t S)"
unfolding fv⇩s⇩s⇩t_def fv_list⇩s⇩s⇩t_def by (induct S) (simp_all add: fv_list⇩s⇩s⇩t⇩p_is_fv⇩s⇩s⇩t⇩p)
lemma trms⇩s⇩s⇩t⇩p_finite[simp]: "finite (trms⇩s⇩s⇩t⇩p x)"
by (cases x) auto
lemma trms⇩s⇩s⇩t_finite[simp]: "finite (trms⇩s⇩s⇩t S)"
using trms⇩s⇩s⇩t⇩p_finite unfolding trms⇩s⇩s⇩t_def by (induct S) auto
lemma vars⇩s⇩s⇩t⇩p_finite[simp]: "finite (vars⇩s⇩s⇩t⇩p x)"
by (cases x) auto
lemma vars⇩s⇩s⇩t_finite[simp]: "finite (vars⇩s⇩s⇩t S)"
using vars⇩s⇩s⇩t⇩p_finite unfolding vars⇩s⇩s⇩t_def by (induct S) auto
lemma fv⇩s⇩s⇩t⇩p_finite[simp]: "finite (fv⇩s⇩s⇩t⇩p x)"
by (cases x) auto
lemma fv⇩s⇩s⇩t_finite[simp]: "finite (fv⇩s⇩s⇩t S)"
using fv⇩s⇩s⇩t⇩p_finite unfolding fv⇩s⇩s⇩t_def by (induct S) auto
lemma bvars⇩s⇩s⇩t⇩p_finite[simp]: "finite (set (bvars⇩s⇩s⇩t⇩p x))"
by (rule finite_set)
lemma bvars⇩s⇩s⇩t_finite[simp]: "finite (bvars⇩s⇩s⇩t S)"
using bvars⇩s⇩s⇩t⇩p_finite unfolding bvars⇩s⇩s⇩t_def by (induct S) auto
lemma subst_sst_nil[simp]: "[] ⋅⇩s⇩s⇩t δ = []"
by (simp add: subst_apply_stateful_strand_def)
lemma db⇩s⇩s⇩t_nil[simp]: "db⇩s⇩s⇩t [] ℐ = []"
by (simp add: db⇩s⇩s⇩t_def)
lemma ik⇩s⇩s⇩t_nil[simp]: "ik⇩s⇩s⇩t [] = {}"
by (simp add: ik⇩s⇩s⇩t_def)
lemma ik⇩s⇩s⇩t_append[simp]: "ik⇩s⇩s⇩t (A@B) = ik⇩s⇩s⇩t A ∪ ik⇩s⇩s⇩t B"
by (auto simp add: ik⇩s⇩s⇩t_def)
lemma ik⇩s⇩s⇩t_subst: "ik⇩s⇩s⇩t (A ⋅⇩s⇩s⇩t δ) = ik⇩s⇩s⇩t A ⋅⇩s⇩e⇩t δ"
proof (induction A)
case (Cons a A) thus ?case
by (cases a) (auto simp add: ik⇩s⇩s⇩t_def subst_apply_stateful_strand_def)
qed simp
lemma db⇩s⇩s⇩t_set_is_dbupd⇩s⇩s⇩t: "set (db'⇩s⇩s⇩t A I D) = dbupd⇩s⇩s⇩t A I (set D)" (is "?A = ?B")
proof
show "?A ⊆ ?B"
proof
fix t s show "(t,s) ∈ ?A ⟹ (t,s) ∈ ?B" by (induct rule: db'⇩s⇩s⇩t.induct) auto
qed
show "?B ⊆ ?A"
proof
fix t s show "(t,s) ∈ ?B ⟹ (t,s) ∈ ?A" by (induct arbitrary: D rule: dbupd⇩s⇩s⇩t.induct) auto
qed
qed
lemma dbupd⇩s⇩s⇩t_no_upd:
assumes "∀a ∈ set A. ¬is_Insert a ∧ ¬is_Delete a"
shows "dbupd⇩s⇩s⇩t A I D = D"
using assms
proof (induction A)
case (Cons a A) thus ?case by (cases a) auto
qed simp
lemma db⇩s⇩s⇩t_no_upd:
assumes "∀a ∈ set A. ¬is_Insert a ∧ ¬is_Delete a"
shows "db'⇩s⇩s⇩t A I D = D"
using assms
proof (induction A)
case (Cons a A) thus ?case by (cases a) auto
qed simp
lemma db⇩s⇩s⇩t_no_upd_append:
assumes "∀b ∈ set B. ¬is_Insert b ∧ ¬is_Delete b"
shows "db'⇩s⇩s⇩t A = db'⇩s⇩s⇩t (A@B)"
using assms
proof (induction A)
case Nil thus ?case by (simp add: db⇩s⇩s⇩t_no_upd)
next
case (Cons a A) thus ?case by (cases a) simp_all
qed
lemma db⇩s⇩s⇩t_append:
"db'⇩s⇩s⇩t (A@B) I D = db'⇩s⇩s⇩t B I (db'⇩s⇩s⇩t A I D)"
proof (induction A arbitrary: D)
case (Cons a A) thus ?case by (cases a) auto
qed simp
lemma db⇩s⇩s⇩t_in_cases:
assumes "(t,s) ∈ set (db'⇩s⇩s⇩t A I D)"
shows "(t,s) ∈ set D ∨ (∃t' s'. insert⟨t',s'⟩ ∈ set A ∧ t = t' ⋅ I ∧ s = s' ⋅ I)"
using assms
proof (induction A arbitrary: D)
case (Cons a A) thus ?case by (cases a) fastforce+
qed simp
lemma db⇩s⇩s⇩t_in_cases':
assumes "(t,s) ∈ set (db'⇩s⇩s⇩t A I D)"
and "(t,s) ∉ set D"
shows "∃B C t' s'. A = B@insert⟨t',s'⟩#C ∧ t = t' ⋅ I ∧ s = s' ⋅ I ∧
(∀t'' s''. delete⟨t'',s''⟩ ∈ set C ⟶ t ≠ t'' ⋅ I ∨ s ≠ s'' ⋅ I)"
using assms(1)
proof (induction A rule: List.rev_induct)
case (snoc a A)
note * = snoc db⇩s⇩s⇩t_append[of A "[a]" I D]
thus ?case
proof (cases a)
case (Insert t' s')
thus ?thesis using * by (cases "(t,s) ∈ set (db'⇩s⇩s⇩t A I D)") force+
next
case (Delete t' s')
hence **: "t ≠ t' ⋅ I ∨ s ≠ s' ⋅ I" using * by simp
have "(t,s) ∈ set (db'⇩s⇩s⇩t A I D)" using * Delete by force
then obtain B C u v where B:
"A = B@insert⟨u,v⟩#C" "t = u ⋅ I" "s = v ⋅ I"
"∀t' s'. delete⟨t',s'⟩ ∈ set C ⟶ t ≠ t' ⋅ I ∨ s ≠ s' ⋅ I"
using snoc.IH by moura
have "A@[a] = B@insert⟨u,v⟩#(C@[a])"
"∀t' s'. delete⟨t',s'⟩ ∈ set (C@[a]) ⟶ t ≠ t' ⋅ I ∨ s ≠ s' ⋅ I"
using B(1,4) Delete ** by auto
thus ?thesis using B(2,3) by blast
qed force+
qed (simp add: assms(2))
lemma db⇩s⇩s⇩t_filter:
"db'⇩s⇩s⇩t A I D = db'⇩s⇩s⇩t (filter is_Update A) I D"
by (induct A I D rule: db'⇩s⇩s⇩t.induct) simp_all
lemma subst_sst_cons: "a#A ⋅⇩s⇩s⇩t δ = (a ⋅⇩s⇩s⇩t⇩p δ)#(A ⋅⇩s⇩s⇩t δ)"
by (simp add: subst_apply_stateful_strand_def)
lemma subst_sst_snoc: "A@[a] ⋅⇩s⇩s⇩t δ = (A ⋅⇩s⇩s⇩t δ)@[a ⋅⇩s⇩s⇩t⇩p δ]"
by (simp add: subst_apply_stateful_strand_def)
lemma subst_sst_append[simp]: "A@B ⋅⇩s⇩s⇩t δ = (A ⋅⇩s⇩s⇩t δ)@(B ⋅⇩s⇩s⇩t δ)"
by (simp add: subst_apply_stateful_strand_def)
lemma sst_vars_append_subset:
"fv⇩s⇩s⇩t A ⊆ fv⇩s⇩s⇩t (A@B)" "bvars⇩s⇩s⇩t A ⊆ bvars⇩s⇩s⇩t (A@B)"
"fv⇩s⇩s⇩t B ⊆ fv⇩s⇩s⇩t (A@B)" "bvars⇩s⇩s⇩t B ⊆ bvars⇩s⇩s⇩t (A@B)"
by auto
lemma sst_vars_disj_cons[simp]: "fv⇩s⇩s⇩t (a#A) ∩ bvars⇩s⇩s⇩t (a#A) = {} ⟹ fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}"
unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by auto
lemma fv⇩s⇩s⇩t_cons_subset[simp]: "fv⇩s⇩s⇩t A ⊆ fv⇩s⇩s⇩t (a#A)"
by auto
lemma fv⇩s⇩s⇩t⇩p_subst_cases[simp]:
"fv⇩s⇩s⇩t⇩p (send⟨t⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ)"
"fv⇩s⇩s⇩t⇩p (receive⟨t⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ)"
"fv⇩s⇩s⇩t⇩p (⟨c: t ≐ s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"fv⇩s⇩s⇩t⇩p (insert⟨t,s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"fv⇩s⇩s⇩t⇩p (delete⟨t,s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"fv⇩s⇩s⇩t⇩p (⟨c: t ∈ s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"fv⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩ ⋅⇩s⇩s⇩t⇩p θ) =
fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) - set X"
by simp_all
lemma vars⇩s⇩s⇩t⇩p_cases[simp]:
"vars⇩s⇩s⇩t⇩p (send⟨t⟩) = fv t"
"vars⇩s⇩s⇩t⇩p (receive⟨t⟩) = fv t"
"vars⇩s⇩s⇩t⇩p (⟨c: t ≐ s⟩) = fv t ∪ fv s"
"vars⇩s⇩s⇩t⇩p (insert⟨t,s⟩) = fv t ∪ fv s"
"vars⇩s⇩s⇩t⇩p (delete⟨t,s⟩) = fv t ∪ fv s"
"vars⇩s⇩s⇩t⇩p (⟨c: t ∈ s⟩) = fv t ∪ fv s"
"vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩) = fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G ∪ set X" (is ?A)
"vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: [(t,s)] ∨∉: []⟩) = fv t ∪ fv s ∪ set X" (is ?B)
"vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: [] ∨∉: [(t,s)]⟩) = fv t ∪ fv s ∪ set X" (is ?C)
proof
show ?A ?B ?C by auto
qed simp_all
lemma vars⇩s⇩s⇩t⇩p_subst_cases[simp]:
"vars⇩s⇩s⇩t⇩p (send⟨t⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ)"
"vars⇩s⇩s⇩t⇩p (receive⟨t⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ)"
"vars⇩s⇩s⇩t⇩p (⟨c: t ≐ s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"vars⇩s⇩s⇩t⇩p (insert⟨t,s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"vars⇩s⇩s⇩t⇩p (delete⟨t,s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"vars⇩s⇩s⇩t⇩p (⟨c: t ∈ s⟩ ⋅⇩s⇩s⇩t⇩p θ) = fv (t ⋅ θ) ∪ fv (s ⋅ θ)"
"vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩ ⋅⇩s⇩s⇩t⇩p θ) =
fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∪ set X" (is ?A)
"vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: [(t,s)] ∨∉: []⟩ ⋅⇩s⇩s⇩t⇩p θ) =
fv (t ⋅ rm_vars (set X) θ) ∪ fv (s ⋅ rm_vars (set X) θ) ∪ set X" (is ?B)
"vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: [] ∨∉: [(t,s)]⟩ ⋅⇩s⇩s⇩t⇩p θ) =
fv (t ⋅ rm_vars (set X) θ) ∪ fv (s ⋅ rm_vars (set X) θ) ∪ set X" (is ?C)
proof
show ?A ?B ?C by auto
qed simp_all
lemma bvars⇩s⇩s⇩t_cons_subset: "bvars⇩s⇩s⇩t A ⊆ bvars⇩s⇩s⇩t (a#A)"
by auto
lemma bvars⇩s⇩s⇩t⇩p_subst: "bvars⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ) = bvars⇩s⇩s⇩t⇩p a"
by (cases a) auto
lemma bvars⇩s⇩s⇩t_subst: "bvars⇩s⇩s⇩t (A ⋅⇩s⇩s⇩t δ) = bvars⇩s⇩s⇩t A"
using bvars⇩s⇩s⇩t⇩p_subst[of _ δ]
by (induct A) (simp_all add: subst_apply_stateful_strand_def)
lemma bvars⇩s⇩s⇩t⇩p_set_cases[simp]:
"set (bvars⇩s⇩s⇩t⇩p (send⟨t⟩)) = {}"
"set (bvars⇩s⇩s⇩t⇩p (receive⟨t⟩)) = {}"
"set (bvars⇩s⇩s⇩t⇩p (⟨c: t ≐ s⟩)) = {}"
"set (bvars⇩s⇩s⇩t⇩p (insert⟨t,s⟩)) = {}"
"set (bvars⇩s⇩s⇩t⇩p (delete⟨t,s⟩)) = {}"
"set (bvars⇩s⇩s⇩t⇩p (⟨c: t ∈ s⟩)) = {}"
"set (bvars⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩)) = set X"
by simp_all
lemma bvars⇩s⇩s⇩t⇩p_NegChecks: "¬is_NegChecks a ⟹ bvars⇩s⇩s⇩t⇩p a = []"
by (cases a) simp_all
lemma bvars⇩s⇩s⇩t_NegChecks: "bvars⇩s⇩s⇩t A = bvars⇩s⇩s⇩t (filter is_NegChecks A)"
proof (induction A)
case (Cons a A) thus ?case by (cases a) fastforce+
qed simp
lemma vars⇩s⇩s⇩t_append[simp]: "vars⇩s⇩s⇩t (A@B) = vars⇩s⇩s⇩t A ∪ vars⇩s⇩s⇩t B"
by (simp add: vars⇩s⇩s⇩t_def)
lemma vars⇩s⇩s⇩t_Nil[simp]: "vars⇩s⇩s⇩t [] = {}"
by (simp add: vars⇩s⇩s⇩t_def)
lemma vars⇩s⇩s⇩t_Cons: "vars⇩s⇩s⇩t (a#A) = vars⇩s⇩s⇩t⇩p a ∪ vars⇩s⇩s⇩t A"
by (simp add: vars⇩s⇩s⇩t_def)
lemma fv⇩s⇩s⇩t_Cons: "fv⇩s⇩s⇩t (a#A) = fv⇩s⇩s⇩t⇩p a ∪ fv⇩s⇩s⇩t A"
unfolding fv⇩s⇩s⇩t_def by simp
lemma bvars⇩s⇩s⇩t_Cons: "bvars⇩s⇩s⇩t (a#A) = set (bvars⇩s⇩s⇩t⇩p a) ∪ bvars⇩s⇩s⇩t A"
unfolding bvars⇩s⇩s⇩t_def by auto
lemma vars⇩s⇩s⇩t_Cons'[simp]:
"vars⇩s⇩s⇩t (send⟨t⟩#A) = vars⇩s⇩s⇩t⇩p (send⟨t⟩) ∪ vars⇩s⇩s⇩t A"
"vars⇩s⇩s⇩t (receive⟨t⟩#A) = vars⇩s⇩s⇩t⇩p (receive⟨t⟩) ∪ vars⇩s⇩s⇩t A"
"vars⇩s⇩s⇩t (⟨a: t ≐ s⟩#A) = vars⇩s⇩s⇩t⇩p (⟨a: t ≐ s⟩) ∪ vars⇩s⇩s⇩t A"
"vars⇩s⇩s⇩t (insert⟨t,s⟩#A) = vars⇩s⇩s⇩t⇩p (insert⟨t,s⟩) ∪ vars⇩s⇩s⇩t A"
"vars⇩s⇩s⇩t (delete⟨t,s⟩#A) = vars⇩s⇩s⇩t⇩p (delete⟨t,s⟩) ∪ vars⇩s⇩s⇩t A"
"vars⇩s⇩s⇩t (⟨a: t ∈ s⟩#A) = vars⇩s⇩s⇩t⇩p (⟨a: t ∈ s⟩) ∪ vars⇩s⇩s⇩t A"
"vars⇩s⇩s⇩t (∀X⟨∨≠: F ∨∉: G⟩#A) = vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩) ∪ vars⇩s⇩s⇩t A"
by (simp_all add: vars⇩s⇩s⇩t_def)
lemma vars⇩s⇩s⇩t⇩p_is_fv⇩s⇩s⇩t⇩p_bvars⇩s⇩s⇩t⇩p:
fixes x::"('a,'b) stateful_strand_step"
shows "vars⇩s⇩s⇩t⇩p x = fv⇩s⇩s⇩t⇩p x ∪ set (bvars⇩s⇩s⇩t⇩p x)"
proof (cases x)
case (NegChecks X F G) thus ?thesis by (induct F) force+
qed simp_all
lemma vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t:
fixes S::"('a,'b) stateful_strand"
shows "vars⇩s⇩s⇩t S = fv⇩s⇩s⇩t S ∪ bvars⇩s⇩s⇩t S"
proof (induction S)
case (Cons x S) thus ?case
using vars⇩s⇩s⇩t⇩p_is_fv⇩s⇩s⇩t⇩p_bvars⇩s⇩s⇩t⇩p[of x]
by (auto simp add: vars⇩s⇩s⇩t_def)
qed simp
lemma vars⇩s⇩s⇩t⇩p_NegCheck[simp]:
"vars⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩) = set X ∪ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G"
by (simp_all add: sup_commute sup_left_commute vars⇩s⇩s⇩t⇩p_is_fv⇩s⇩s⇩t⇩p_bvars⇩s⇩s⇩t⇩p)
lemma bvars⇩s⇩s⇩t⇩p_NegCheck[simp]:
"bvars⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩) = X"
"set (bvars⇩s⇩s⇩t⇩p (∀[]⟨∨≠: F ∨∉: G⟩)) = {}"
by simp_all
lemma fv⇩s⇩s⇩t⇩p_NegCheck[simp]:
"fv⇩s⇩s⇩t⇩p (∀X⟨∨≠: F ∨∉: G⟩) = fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G - set X"
"fv⇩s⇩s⇩t⇩p (∀[]⟨∨≠: F ∨∉: G⟩) = fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G"
"fv⇩s⇩s⇩t⇩p (⟨t != s⟩) = fv t ∪ fv s"
"fv⇩s⇩s⇩t⇩p (⟨t not in s⟩) = fv t ∪ fv s"
by simp_all
lemma fv⇩s⇩s⇩t_append[simp]: "fv⇩s⇩s⇩t (A@B) = fv⇩s⇩s⇩t A ∪ fv⇩s⇩s⇩t B"
by simp
lemma bvars⇩s⇩s⇩t_append[simp]: "bvars⇩s⇩s⇩t (A@B) = bvars⇩s⇩s⇩t A ∪ bvars⇩s⇩s⇩t B"
by auto
lemma fv⇩s⇩s⇩t⇩p_is_subterm_trms⇩s⇩s⇩t⇩p:
assumes "x ∈ fv⇩s⇩s⇩t⇩p a"
shows "Var x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p a)"
using assms var_is_subterm
proof (cases a)
case (NegChecks X F F')
hence "x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s F' - set X" using assms by simp
thus ?thesis using NegChecks var_is_subterm by fastforce
qed force+
lemma fv⇩s⇩s⇩t_is_subterm_trms⇩s⇩s⇩t: "x ∈ fv⇩s⇩s⇩t A ⟹ Var x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t A)"
proof (induction A)
case (Cons a A) thus ?case using fv⇩s⇩s⇩t⇩p_is_subterm_trms⇩s⇩s⇩t⇩p by (cases "x ∈ fv⇩s⇩s⇩t A") auto
qed simp
lemma var_subterm_trms⇩s⇩s⇩t⇩p_is_vars⇩s⇩s⇩t⇩p:
assumes "Var x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p a)"
shows "x ∈ vars⇩s⇩s⇩t⇩p a"
using assms vars_iff_subtermeq
proof (cases a)
case (NegChecks X F F')
hence "Var x ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F ∪ trms⇩p⇩a⇩i⇩r⇩s F')" using assms by simp
thus ?thesis using NegChecks vars_iff_subtermeq by force
qed force+
lemma var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t: "Var x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t A) ⟹ x ∈ vars⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A)
show ?case
proof (cases "Var x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t A)")
case True thus ?thesis using Cons.IH by (simp add: vars⇩s⇩s⇩t_def)
next
case False thus ?thesis
using Cons.prems var_subterm_trms⇩s⇩s⇩t⇩p_is_vars⇩s⇩s⇩t⇩p
by (fastforce simp add: vars⇩s⇩s⇩t_def)
qed
qed simp
lemma var_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t: "Var x ∈ trms⇩s⇩s⇩t A ⟹ x ∈ vars⇩s⇩s⇩t A"
by (meson var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t UN_I term.order_refl)
lemma ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset: "ik⇩s⇩s⇩t A ⊆ trms⇩s⇩s⇩t A"
by (force simp add: ik⇩s⇩s⇩t_def)
lemma var_subterm_ik⇩s⇩s⇩t_is_vars⇩s⇩s⇩t: "Var x ∈ subterms⇩s⇩e⇩t (ik⇩s⇩s⇩t A) ⟹ x ∈ vars⇩s⇩s⇩t A"
using var_subterm_trms⇩s⇩s⇩t_is_vars⇩s⇩s⇩t ik⇩s⇩s⇩t_trms⇩s⇩s⇩t_subset by fast
lemma var_subterm_ik⇩s⇩s⇩t_is_fv⇩s⇩s⇩t:
assumes "Var x ∈ subterms⇩s⇩e⇩t (ik⇩s⇩s⇩t A)"
shows "x ∈ fv⇩s⇩s⇩t A"
proof -
obtain t where t: "Receive t ∈ set A" "Var x ⊑ t" using assms unfolding ik⇩s⇩s⇩t_def by moura
hence "fv t ⊆ fv⇩s⇩s⇩t A" unfolding fv⇩s⇩s⇩t_def by force
thus ?thesis using t(2) by (meson contra_subsetD subterm_is_var)
qed
lemma fv_ik⇩s⇩s⇩t_is_fv⇩s⇩s⇩t:
assumes "x ∈ fv⇩s⇩e⇩t (ik⇩s⇩s⇩t A)"
shows "x ∈ fv⇩s⇩s⇩t A"
using var_subterm_ik⇩s⇩s⇩t_is_fv⇩s⇩s⇩t assms var_is_subterm by fastforce
lemma fv_trms⇩s⇩s⇩t_subset:
"fv⇩s⇩e⇩t (trms⇩s⇩s⇩t S) ⊆ vars⇩s⇩s⇩t S"
"fv⇩s⇩s⇩t S ⊆ fv⇩s⇩e⇩t (trms⇩s⇩s⇩t S)"
proof (induction S)
case (Cons x S)
have *: "fv⇩s⇩e⇩t (trms⇩s⇩s⇩t (x#S)) = fv⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p x) ∪ fv⇩s⇩e⇩t (trms⇩s⇩s⇩t S)"
"fv⇩s⇩s⇩t (x#S) = fv⇩s⇩s⇩t⇩p x ∪ fv⇩s⇩s⇩t S" "vars⇩s⇩s⇩t (x#S) = vars⇩s⇩s⇩t⇩p x ∪ vars⇩s⇩s⇩t S"
unfolding trms⇩s⇩s⇩t_def fv⇩s⇩s⇩t_def vars⇩s⇩s⇩t_def
by auto
{ case 1
show ?case using Cons.IH(1)
proof (cases x)
case (NegChecks X F G)
hence "trms⇩s⇩s⇩t⇩p x = trms⇩p⇩a⇩i⇩r⇩s F ∪ trms⇩p⇩a⇩i⇩r⇩s G"
"vars⇩s⇩s⇩t⇩p x = fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G ∪ set X"
by (simp, meson vars⇩s⇩s⇩t⇩p_cases(7))
hence "fv⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p x) ⊆ vars⇩s⇩s⇩t⇩p x"
using fv_trms⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s[of F] fv_trms⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s[of G]
by auto
thus ?thesis
using Cons.IH(1) *(1,3)
by blast
qed auto
}
{ case 2
show ?case using Cons.IH(2)
proof (cases x)
case (NegChecks X F G)
hence "trms⇩s⇩s⇩t⇩p x = trms⇩p⇩a⇩i⇩r⇩s F ∪ trms⇩p⇩a⇩i⇩r⇩s G"
"fv⇩s⇩s⇩t⇩p x = (fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G) - set X"
by auto
hence "fv⇩s⇩s⇩t⇩p x ⊆ fv⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p x)"
using fv_trms⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s[of F] fv_trms⇩p⇩a⇩i⇩r⇩s_is_fv⇩p⇩a⇩i⇩r⇩s[of G]
by auto
thus ?thesis
using Cons.IH(2) *(1,2)
by blast
qed auto
}
qed simp_all
lemma fv_ik_subset_fv_sst'[simp]: "fv⇩s⇩e⇩t (ik⇩s⇩s⇩t S) ⊆ fv⇩s⇩s⇩t S"
unfolding ik⇩s⇩s⇩t_def by (induct S) auto
lemma fv_ik_subset_vars_sst'[simp]: "fv⇩s⇩e⇩t (ik⇩s⇩s⇩t S) ⊆ vars⇩s⇩s⇩t S"
using fv_ik_subset_fv_sst' fv_trms⇩s⇩s⇩t_subset by fast
lemma ik⇩s⇩s⇩t_var_is_fv: "Var x ∈ subterms⇩s⇩e⇩t (ik⇩s⇩s⇩t A) ⟹ x ∈ fv⇩s⇩s⇩t A"
by (meson fv_ik_subset_fv_sst'[of A] fv_subset_subterms subsetCE term.set_intros(3))
lemma vars⇩s⇩s⇩t⇩p_subst_cases':
assumes x: "x ∈ vars⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)"
shows "x ∈ vars⇩s⇩s⇩t⇩p s ∨ x ∈ fv⇩s⇩e⇩t (θ ` vars⇩s⇩s⇩t⇩p s)"
using x vars_term_subst[of _ θ] vars⇩s⇩s⇩t⇩p_cases(1,2,3,4,5,6) vars⇩s⇩s⇩t⇩p_subst_cases(1,2)[of _ θ]
vars⇩s⇩s⇩t⇩p_subst_cases(3,6)[of _ _ _ θ] vars⇩s⇩s⇩t⇩p_subst_cases(4,5)[of _ _ θ]
proof (cases s)
case (NegChecks X F G)
let ?θ' = "rm_vars (set X) θ"
have "x ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ') ∨ x ∈ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s ?θ') ∨ x ∈ set X"
using vars⇩s⇩s⇩t⇩p_subst_cases(7)[of X F G θ] x NegChecks by simp
hence "x ∈ fv⇩s⇩e⇩t (?θ' ` fv⇩p⇩a⇩i⇩r⇩s F) ∨ x ∈ fv⇩s⇩e⇩t (?θ' ` fv⇩p⇩a⇩i⇩r⇩s G) ∨ x ∈ set X"
using fv⇩p⇩a⇩i⇩r⇩s_subst[of _ ?θ'] by blast
hence "x ∈ fv⇩s⇩e⇩t (θ ` fv⇩p⇩a⇩i⇩r⇩s F) ∨ x ∈ fv⇩s⇩e⇩t (θ ` fv⇩p⇩a⇩i⇩r⇩s G) ∨ x ∈ set X"
using rm_vars_fv⇩s⇩e⇩t_subst by fast
thus ?thesis
using NegChecks vars⇩s⇩s⇩t⇩p_cases(7)[of X F G]
by auto
qed simp_all
lemma vars⇩s⇩s⇩t_subst_cases:
assumes "x ∈ vars⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
shows "x ∈ vars⇩s⇩s⇩t S ∨ x ∈ fv⇩s⇩e⇩t (θ ` vars⇩s⇩s⇩t S)"
using assms
proof (induction S)
case (Cons s S) thus ?case
proof (cases "x ∈ vars⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)")
case False
note * = subst_sst_cons[of s S θ] vars⇩s⇩s⇩t_Cons[of "s ⋅⇩s⇩s⇩t⇩p θ" "S ⋅⇩s⇩s⇩t θ"] vars⇩s⇩s⇩t_Cons[of s S]
have **: "x ∈ vars⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)" using Cons.prems False * by simp
show ?thesis using vars⇩s⇩s⇩t⇩p_subst_cases'[OF **] * by auto
qed (auto simp add: vars⇩s⇩s⇩t_def)
qed simp
lemma subset_subst_pairs_diff_exists:
fixes ℐ::"('a,'b) subst" and D D'::"('a,'b) dbstate"
shows "∃Di. Di ⊆ D ∧ Di ⋅⇩p⇩s⇩e⇩t ℐ = (D ⋅⇩p⇩s⇩e⇩t ℐ) - D'"
by (metis (no_types, lifting) Diff_subset subset_image_iff)
lemma subset_subst_pairs_diff_exists':
fixes ℐ::"('a,'b) subst" and D::"('a,'b) dbstate"
assumes "finite D"
shows "∃Di. Di ⊆ D ∧ Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {d ⋅⇩p ℐ} ∧ d ⋅⇩p ℐ ∉ (D - Di) ⋅⇩p⇩s⇩e⇩t ℐ"
using assms
proof (induction D rule: finite_induct)
case (insert d' D)
then obtain Di where IH: "Di ⊆ D" "Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {d ⋅⇩p ℐ}" "d ⋅⇩p ℐ ∉ (D - Di) ⋅⇩p⇩s⇩e⇩t ℐ" by moura
show ?case
proof (cases "d' ⋅⇩p ℐ = d ⋅⇩p ℐ")
case True
hence "insert d' Di ⊆ insert d' D" "insert d' Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {d ⋅⇩p ℐ}"
"d ⋅⇩p ℐ ∉ (insert d' D - insert d' Di) ⋅⇩p⇩s⇩e⇩t ℐ"
using IH by auto
thus ?thesis by metis
next
case False
hence "Di ⊆ insert d' D" "Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {d ⋅⇩p ℐ}"
"d ⋅⇩p ℐ ∉ (insert d' D - Di) ⋅⇩p⇩s⇩e⇩t ℐ"
using IH by auto
thus ?thesis by metis
qed
qed simp
lemma stateful_strand_step_subst_inI[intro]:
"send⟨t⟩ ∈ set A ⟹ send⟨t ⋅ θ⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"receive⟨t⟩ ∈ set A ⟹ receive⟨t ⋅ θ⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"⟨c: t ≐ s⟩ ∈ set A ⟹ ⟨c: (t ⋅ θ) ≐ (s ⋅ θ)⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"insert⟨t, s⟩ ∈ set A ⟹ insert⟨t ⋅ θ, s ⋅ θ⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"delete⟨t, s⟩ ∈ set A ⟹ delete⟨t ⋅ θ, s ⋅ θ⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"⟨c: t ∈ s⟩ ∈ set A ⟹ ⟨c: (t ⋅ θ) ∈ (s ⋅ θ)⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"∀X⟨∨≠: F ∨∉: G⟩ ∈ set A
⟹ ∀X⟨∨≠: (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∨∉: (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"⟨t != s⟩ ∈ set A ⟹ ⟨t ⋅ θ != s ⋅ θ⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
"⟨t not in s⟩ ∈ set A ⟹ ⟨t ⋅ θ not in s ⋅ θ⟩ ∈ set (A ⋅⇩s⇩s⇩t θ)"
proof (induction A)
case (Cons a A)
note * = subst_sst_cons[of a A θ]
{ case 1 thus ?case using Cons.IH(1) * by (cases a) auto }
{ case 2 thus ?case using Cons.IH(2) * by (cases a) auto }
{ case 3 thus ?case using Cons.IH(3) * by (cases a) auto }
{ case 4 thus ?case using Cons.IH(4) * by (cases a) auto }
{ case 5 thus ?case using Cons.IH(5) * by (cases a) auto }
{ case 6 thus ?case using Cons.IH(6) * by (cases a) auto }
{ case 7 thus ?case using Cons.IH(7) * by (cases a) auto }
{ case 8 thus ?case using Cons.IH(8) * by (cases a) auto }
{ case 9 thus ?case using Cons.IH(9) * by (cases a) auto }
qed simp_all
lemma stateful_strand_step_cases_subst:
"is_Send a = is_Send (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_Receive a = is_Receive (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_Equality a = is_Equality (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_Insert a = is_Insert (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_Delete a = is_Delete (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_InSet a = is_InSet (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_NegChecks a = is_NegChecks (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_Assignment a = is_Assignment (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_Check a = is_Check (a ⋅⇩s⇩s⇩t⇩p θ)"
"is_Update a = is_Update (a ⋅⇩s⇩s⇩t⇩p θ)"
by (cases a; simp_all)+
lemma stateful_strand_step_subst_inv_cases:
"send⟨t⟩ ∈ set (S ⋅⇩s⇩s⇩t σ) ⟹ ∃t'. t = t' ⋅ σ ∧ send⟨t'⟩ ∈ set S"
"receive⟨t⟩ ∈ set (S ⋅⇩s⇩s⇩t σ) ⟹ ∃t'. t = t' ⋅ σ ∧ receive⟨t'⟩ ∈ set S"
"⟨c: t ≐ s⟩ ∈ set (S ⋅⇩s⇩s⇩t σ) ⟹ ∃t' s'. t = t' ⋅ σ ∧ s = s' ⋅ σ ∧ ⟨c: t' ≐ s'⟩ ∈ set S"
"insert⟨t,s⟩ ∈ set (S ⋅⇩s⇩s⇩t σ) ⟹ ∃t' s'. t = t' ⋅ σ ∧ s = s' ⋅ σ ∧ insert⟨t',s'⟩ ∈ set S"
"delete⟨t,s⟩ ∈ set (S ⋅⇩s⇩s⇩t σ) ⟹ ∃t' s'. t = t' ⋅ σ ∧ s = s' ⋅ σ ∧ delete⟨t',s'⟩ ∈ set S"
"⟨c: t ∈ s⟩ ∈ set (S ⋅⇩s⇩s⇩t σ) ⟹ ∃t' s'. t = t' ⋅ σ ∧ s = s' ⋅ σ ∧ ⟨c: t' ∈ s'⟩ ∈ set S"
"∀X⟨∨≠: F ∨∉: G⟩ ∈ set (S ⋅⇩s⇩s⇩t σ) ⟹
∃F' G'. F = F' ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) σ ∧ G = G' ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) σ ∧
∀X⟨∨≠: F' ∨∉: G'⟩ ∈ set S"
proof (induction S)
case (Cons a S)
have *: "x ∈ set (S ⋅⇩s⇩s⇩t σ)"
when "x ∈ set (a#S ⋅⇩s⇩s⇩t σ)" "x ≠ a ⋅⇩s⇩s⇩t⇩p σ" for x
using that by (simp add: subst_apply_stateful_strand_def)
{ case 1 thus ?case using Cons.IH(1)[OF *] by (cases a) auto }
{ case 2 thus ?case using Cons.IH(2)[OF *] by (cases a) auto }
{ case 3 thus ?case using Cons.IH(3)[OF *] by (cases a) auto }
{ case 4 thus ?case using Cons.IH(4)[OF *] by (cases a) auto }
{ case 5 thus ?case using Cons.IH(5)[OF *] by (cases a) auto }
{ case 6 thus ?case using Cons.IH(6)[OF *] by (cases a) auto }
{ case 7 thus ?case using Cons.IH(7)[OF *] by (cases a) auto }
qed simp_all
lemma stateful_strand_step_fv_subset_cases:
"send⟨t⟩ ∈ set S ⟹ fv t ⊆ fv⇩s⇩s⇩t S"
"receive⟨t⟩ ∈ set S ⟹ fv t ⊆ fv⇩s⇩s⇩t S"
"⟨c: t ≐ s⟩ ∈ set S ⟹ fv t ∪ fv s ⊆ fv⇩s⇩s⇩t S"
"insert⟨t,s⟩ ∈ set S ⟹ fv t ∪ fv s ⊆ fv⇩s⇩s⇩t S"
"delete⟨t,s⟩ ∈ set S ⟹ fv t ∪ fv s ⊆ fv⇩s⇩s⇩t S"
"⟨c: t ∈ s⟩ ∈ set S ⟹ fv t ∪ fv s ⊆ fv⇩s⇩s⇩t S"
"∀X⟨∨≠: F ∨∉: G⟩ ∈ set S ⟹ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G - set X ⊆ fv⇩s⇩s⇩t S"
proof (induction S)
case (Cons a S)
{ case 1 thus ?case using Cons.IH(1) by auto }
{ case 2 thus ?case using Cons.IH(2) by auto }
{ case 3 thus ?case using Cons.IH(3) by auto }
{ case 4 thus ?case using Cons.IH(4) by auto }
{ case 5 thus ?case using Cons.IH(5) by auto }
{ case 6 thus ?case using Cons.IH(6) by auto }
{ case 7 thus ?case using Cons.IH(7) by fastforce }
qed simp_all
lemma trms⇩s⇩s⇩t_nil[simp]:
"trms⇩s⇩s⇩t [] = {}"
unfolding trms⇩s⇩s⇩t_def by simp
lemma trms⇩s⇩s⇩t_mono:
"set M ⊆ set N ⟹ trms⇩s⇩s⇩t M ⊆ trms⇩s⇩s⇩t N"
by auto
lemma trms⇩s⇩s⇩t_in:
assumes "t ∈ trms⇩s⇩s⇩t S"
shows "∃a ∈ set S. t ∈ trms⇩s⇩s⇩t⇩p a"
using assms unfolding trms⇩s⇩s⇩t_def by simp
lemma trms⇩s⇩s⇩t_cons: "trms⇩s⇩s⇩t (a#A) = trms⇩s⇩s⇩t⇩p a ∪ trms⇩s⇩s⇩t A"
unfolding trms⇩s⇩s⇩t_def by force
lemma trms⇩s⇩s⇩t_append[simp]: "trms⇩s⇩s⇩t (A@B) = trms⇩s⇩s⇩t A ∪ trms⇩s⇩s⇩t B"
unfolding trms⇩s⇩s⇩t_def by force
lemma trms⇩s⇩s⇩t⇩p_subst:
assumes "set (bvars⇩s⇩s⇩t⇩p a) ∩ subst_domain θ = {}"
shows "trms⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p θ) = trms⇩s⇩s⇩t⇩p a ⋅⇩s⇩e⇩t θ"
proof (cases a)
case (NegChecks X F G)
hence "rm_vars (set X) θ = θ" using assms rm_vars_apply'[of θ "set X"] by auto
hence "trms⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p θ) = trms⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s θ) ∪ trms⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s θ)"
"trms⇩s⇩s⇩t⇩p a ⋅⇩s⇩e⇩t θ = (trms⇩p⇩a⇩i⇩r⇩s F ⋅⇩s⇩e⇩t θ) ∪ (trms⇩p⇩a⇩i⇩r⇩s G ⋅⇩s⇩e⇩t θ)"
using NegChecks image_Un by simp_all
thus ?thesis by (metis trms⇩p⇩a⇩i⇩r⇩s_subst)
qed simp_all
lemma trms⇩s⇩s⇩t⇩p_subst':
assumes "¬is_NegChecks a"
shows "trms⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p θ) = trms⇩s⇩s⇩t⇩p a ⋅⇩s⇩e⇩t θ"
using assms by (cases a) simp_all
lemma trms⇩s⇩s⇩t⇩p_subst'':
fixes t::"('a,'b) term" and δ::"('a,'b) subst"
assumes "t ∈ trms⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ)"
shows "∃s ∈ trms⇩s⇩s⇩t⇩p b. t = s ⋅ rm_vars (set (bvars⇩s⇩s⇩t⇩p b)) δ"
proof (cases "is_NegChecks b")
case True
then obtain X F G where *: "b = NegChecks X F G" by (cases b) moura+
thus ?thesis using assms trms⇩p⇩a⇩i⇩r⇩s_subst[of _ "rm_vars (set X) δ"] by auto
next
case False
hence "trms⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) = trms⇩s⇩s⇩t⇩p b ⋅⇩s⇩e⇩t rm_vars (set (bvars⇩s⇩s⇩t⇩p b)) δ"
using trms⇩s⇩s⇩t⇩p_subst' bvars⇩s⇩s⇩t⇩p_NegChecks
by fastforce
thus ?thesis using assms by fast
qed
lemma trms⇩s⇩s⇩t⇩p_subst''':
fixes t::"('a,'b) term" and δ θ::"('a,'b) subst"
assumes "t ∈ trms⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) ⋅⇩s⇩e⇩t θ"
shows "∃s ∈ trms⇩s⇩s⇩t⇩p b. t = s ⋅ rm_vars (set (bvars⇩s⇩s⇩t⇩p b)) δ ∘⇩s θ"
proof -
obtain s where s: "s ∈ trms⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ)" "t = s ⋅ θ" using assms by moura
show ?thesis using trms⇩s⇩s⇩t⇩p_subst''[OF s(1)] s(2) by auto
qed
lemma trms⇩s⇩s⇩t_subst:
assumes "bvars⇩s⇩s⇩t S ∩ subst_domain θ = {}"
shows "trms⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ) = trms⇩s⇩s⇩t S ⋅⇩s⇩e⇩t θ"
using assms
proof (induction S)
case (Cons a S)
hence IH: "trms⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ) = trms⇩s⇩s⇩t S ⋅⇩s⇩e⇩t θ" and *: "set (bvars⇩s⇩s⇩t⇩p a) ∩ subst_domain θ = {}"
by auto
show ?case using trms⇩s⇩s⇩t⇩p_subst[OF *] IH by (auto simp add: subst_apply_stateful_strand_def)
qed simp
lemma trms⇩s⇩s⇩t_subst_cons:
"trms⇩s⇩s⇩t (a#A ⋅⇩s⇩s⇩t δ) = trms⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ) ∪ trms⇩s⇩s⇩t (A ⋅⇩s⇩s⇩t δ)"
using subst_sst_cons[of a A δ] trms⇩s⇩s⇩t_cons[of a A] trms⇩s⇩s⇩t_append by simp
lemma (in intruder_model) wf⇩t⇩r⇩m⇩s_trms⇩s⇩s⇩t⇩p_subst:
assumes "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t⇩p a ⋅⇩s⇩e⇩t δ)"
shows "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ))"
using assms
proof (cases a)
case (NegChecks X F G)
hence *: "trms⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ) =
(trms⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ)) ∪ (trms⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ))"
by simp
have "trms⇩s⇩s⇩t⇩p a ⋅⇩s⇩e⇩t δ = (trms⇩p⇩a⇩i⇩r⇩s F ⋅⇩s⇩e⇩t δ) ∪ (trms⇩p⇩a⇩i⇩r⇩s G ⋅⇩s⇩e⇩t δ)"
using NegChecks image_Un by simp
hence "wf⇩t⇩r⇩m⇩s (trms⇩p⇩a⇩i⇩r⇩s F ⋅⇩s⇩e⇩t δ)" "wf⇩t⇩r⇩m⇩s (trms⇩p⇩a⇩i⇩r⇩s G ⋅⇩s⇩e⇩t δ)" using * assms by auto
hence "wf⇩t⇩r⇩m⇩s (trms⇩p⇩a⇩i⇩r⇩s F ⋅⇩s⇩e⇩t rm_vars (set X) δ)"
"wf⇩t⇩r⇩m⇩s (trms⇩p⇩a⇩i⇩r⇩s G ⋅⇩s⇩e⇩t rm_vars (set X) δ)"
using wf_trms_subst_rm_vars[of δ "trms⇩p⇩a⇩i⇩r⇩s F" "set X"]
wf_trms_subst_rm_vars[of δ "trms⇩p⇩a⇩i⇩r⇩s G" "set X"]
by fast+
thus ?thesis
using * trms⇩p⇩a⇩i⇩r⇩s_subst[of _ "rm_vars (set X) δ"]
by auto
qed auto
lemma trms⇩s⇩s⇩t_fv_vars⇩s⇩s⇩t_subset: "t ∈ trms⇩s⇩s⇩t A ⟹ fv t ⊆ vars⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A) thus ?case by (cases a) auto
qed simp
lemma trms⇩s⇩s⇩t_fv_subst_subset:
assumes "t ∈ trms⇩s⇩s⇩t S" "subst_domain θ ∩ bvars⇩s⇩s⇩t S = {}"
shows "fv (t ⋅ θ) ⊆ vars⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using assms
proof (induction S)
case (Cons s S) show ?case
proof (cases "t ∈ trms⇩s⇩s⇩t S")
case True
hence "fv (t ⋅ θ) ⊆ vars⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)" using Cons.IH Cons.prems by auto
thus ?thesis using subst_sst_cons[of s S θ] unfolding vars⇩s⇩s⇩t_def by auto
next
case False
hence *: "t ∈ trms⇩s⇩s⇩t⇩p s" "subst_domain θ ∩ set (bvars⇩s⇩s⇩t⇩p s) = {}" using Cons.prems by auto
hence "fv (t ⋅ θ) ⊆ vars⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)"
proof (cases s)
case (NegChecks X F G)
hence **: "t ∈ trms⇩p⇩a⇩i⇩r⇩s F ∨ t ∈ trms⇩p⇩a⇩i⇩r⇩s G" using *(1) by auto
have ***: "rm_vars (set X) θ = θ" using *(2) NegChecks rm_vars_apply' by auto
have "fv (t ⋅ θ) ⊆ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)"
using ** *** trms⇩p⇩a⇩i⇩r⇩s_fv_subst_subset[of t _ θ] by auto
thus ?thesis using *(2) using NegChecks vars⇩s⇩s⇩t⇩p_subst_cases(7)[of X F G θ] by blast
qed auto
thus ?thesis using subst_sst_cons[of s S θ] unfolding vars⇩s⇩s⇩t_def by auto
qed
qed simp
lemma trms⇩s⇩s⇩t_fv_subst_subset':
assumes "t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t S)" "fv t ∩ bvars⇩s⇩s⇩t S = {}" "fv (t ⋅ θ) ∩ bvars⇩s⇩s⇩t S = {}"
shows "fv (t ⋅ θ) ⊆ fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using assms
proof (induction S)
case (Cons s S) show ?case
proof (cases "t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t S)")
case True
hence "fv (t ⋅ θ) ⊆ fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)" using Cons.IH Cons.prems by auto
thus ?thesis using subst_sst_cons[of s S θ] unfolding vars⇩s⇩s⇩t_def by auto
next
case False
hence 0: "t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p s)" "fv t ∩ set (bvars⇩s⇩s⇩t⇩p s) = {}"
"fv (t ⋅ θ) ∩ set (bvars⇩s⇩s⇩t⇩p s) = {}"
using Cons.prems by auto
note 1 = UN_Un UN_insert fv⇩s⇩e⇩t.simps subst_apply_fv_subset subst_apply_fv_unfold
subst_apply_term_empty sup_bot.comm_neutral fv_subterms_set fv_subset[OF 0(1)]
note 2 = subst_apply_fv_union
have "fv (t ⋅ θ) ⊆ fv⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)"
proof (cases s)
case (NegChecks X F G)
hence 3: "t ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ∨ t ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s G)" using 0(1) by auto
have "t ⋅ rm_vars (set X) θ = t ⋅ θ" using 0(2) NegChecks rm_vars_ident[of t] by auto
hence "fv (t ⋅ θ) ⊆ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)"
using 3 trms⇩p⇩a⇩i⇩r⇩s_fv_subst_subset'[of t _ "rm_vars (set X) θ"] by fastforce
thus ?thesis using 0(2,3) NegChecks fv⇩s⇩s⇩t⇩p_subst_cases(7)[of X F G θ] by auto
qed (metis (no_types, lifting) 1 trms⇩s⇩s⇩t⇩p.simps(1) fv⇩s⇩s⇩t⇩p_subst_cases(1),
metis (no_types, lifting) 1 trms⇩s⇩s⇩t⇩p.simps(2) fv⇩s⇩s⇩t⇩p_subst_cases(2),
metis (no_types, lifting) 1 2 trms⇩s⇩s⇩t⇩p.simps(3) fv⇩s⇩s⇩t⇩p_subst_cases(3),
metis (no_types, lifting) 1 2 trms⇩s⇩s⇩t⇩p.simps(4) fv⇩s⇩s⇩t⇩p_subst_cases(4),
metis (no_types, lifting) 1 2 trms⇩s⇩s⇩t⇩p.simps(5) fv⇩s⇩s⇩t⇩p_subst_cases(5),
metis (no_types, lifting) 1 2 trms⇩s⇩s⇩t⇩p.simps(6) fv⇩s⇩s⇩t⇩p_subst_cases(6))
thus ?thesis using subst_sst_cons[of s S θ] unfolding fv⇩s⇩s⇩t_def by auto
qed
qed simp
lemma trms⇩s⇩s⇩t⇩p_funs_term_cases:
assumes "t ∈ trms⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)" "f ∈ funs_term t"
shows "(∃u ∈ trms⇩s⇩s⇩t⇩p s. f ∈ funs_term u) ∨ (∃x ∈ fv⇩s⇩s⇩t⇩p s. f ∈ funs_term (θ x))"
using assms
proof (cases s)
case (NegChecks X F G)
hence "t ∈ trms⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∨ t ∈ trms⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)"
using assms(1) by auto
hence "(∃u∈trms⇩p⇩a⇩i⇩r⇩s F. f ∈ funs_term u) ∨ (∃x∈fv⇩p⇩a⇩i⇩r⇩s F. f ∈ funs_term (rm_vars (set X) θ x)) ∨
(∃u∈trms⇩p⇩a⇩i⇩r⇩s G. f ∈ funs_term u) ∨ (∃x∈fv⇩p⇩a⇩i⇩r⇩s G. f ∈ funs_term (rm_vars (set X) θ x))"
using trms⇩p⇩a⇩i⇩r⇩s_funs_term_cases[OF _ assms(2), of _ "rm_vars (set X) θ"] by meson
hence "(∃u ∈ trms⇩p⇩a⇩i⇩r⇩s F ∪ trms⇩p⇩a⇩i⇩r⇩s G. f ∈ funs_term u) ∨
(∃x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G. f ∈ funs_term (rm_vars (set X) θ x))"
by blast
thus ?thesis
proof
assume "∃x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G. f ∈ funs_term (rm_vars (set X) θ x)"
then obtain x where x: "x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G" "f ∈ funs_term (rm_vars (set X) θ x)"
by auto
hence "x ∉ set X" "rm_vars (set X) θ x = θ x" by auto
thus ?thesis using x by (auto simp add: assms NegChecks)
qed (auto simp add: assms NegChecks)
qed (use assms funs_term_subst[of _ θ] in auto)
lemma trms⇩s⇩s⇩t_funs_term_cases:
assumes "t ∈ trms⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)" "f ∈ funs_term t"
shows "(∃u ∈ trms⇩s⇩s⇩t S. f ∈ funs_term u) ∨ (∃x ∈ fv⇩s⇩s⇩t S. f ∈ funs_term (θ x))"
using assms(1)
proof (induction S)
case (Cons s S) thus ?case
proof (cases "t ∈ trms⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)")
case False
hence "t ∈ trms⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)" using Cons.prems(1) subst_sst_cons[of s S θ] trms⇩s⇩s⇩t_cons by auto
thus ?thesis using trms⇩s⇩s⇩t⇩p_funs_term_cases[OF _ assms(2)] by fastforce
qed auto
qed simp
lemma fv⇩s⇩s⇩t_is_subterm_trms⇩s⇩s⇩t_subst:
assumes "x ∈ fv⇩s⇩s⇩t T"
and "bvars⇩s⇩s⇩t T ∩ subst_domain θ = {}"
shows "θ x ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t (T ⋅⇩s⇩s⇩t θ))"
using trms⇩s⇩s⇩t_subst[OF assms(2)] subterms_subst_subset'[of θ "trms⇩s⇩s⇩t T"]
fv⇩s⇩s⇩t_is_subterm_trms⇩s⇩s⇩t[OF assms(1)]
by (metis (no_types, lifting) image_iff subset_iff subst_apply_term.simps(1))
lemma fv⇩s⇩s⇩t_subst_fv_subset:
assumes "x ∈ fv⇩s⇩s⇩t S" "x ∉ bvars⇩s⇩s⇩t S" "fv (θ x) ∩ bvars⇩s⇩s⇩t S = {}"
shows "fv (θ x) ⊆ fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using assms
proof (induction S)
case (Cons a S)
note 1 = fv_subst_subset[of _ _ θ]
note 2 = subst_apply_fv_union subst_apply_fv_unfold[of _ θ] fv_subset image_eqI
note 3 = fv⇩s⇩s⇩t⇩p_subst_cases
note 4 = fv⇩s⇩s⇩t⇩p.simps
from Cons show ?case
proof (cases "x ∈ fv⇩s⇩s⇩t S")
case False
hence 5: "x ∈ fv⇩s⇩s⇩t⇩p a" " fv (θ x) ∩ set (bvars⇩s⇩s⇩t⇩p a) = {}" "x ∉ set (bvars⇩s⇩s⇩t⇩p a)"
using Cons.prems by auto
hence "fv (θ x) ⊆ fv⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p θ)"
proof (cases a)
case (NegChecks X F G)
let ?δ = "rm_vars (set X) θ"
have *: "x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G" using NegChecks 5(1) by auto
have **: "fv (θ x) ∩ set X = {}" using NegChecks 5(2) by simp
have ***: "θ x = ?δ x" using NegChecks 5(3) by auto
have "fv (θ x) ⊆ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s ?δ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s ?δ)"
using fv⇩p⇩a⇩i⇩r⇩s_subst_fv_subset[of x _ ?δ] * *** by auto
thus ?thesis using NegChecks ** by auto
qed (metis (full_types) 1 5(1) 3(1) 4(1), metis (full_types) 1 5(1) 3(2) 4(2),
metis (full_types) 2 5(1) 3(3) 4(3), metis (full_types) 2 5(1) 3(4) 4(4),
metis (full_types) 2 5(1) 3(5) 4(5), metis (full_types) 2 5(1) 3(6) 4(6))
thus ?thesis by (auto simp add: subst_sst_cons[of a S θ])
qed (auto simp add: subst_sst_cons[of a S θ])
qed simp
lemma (in intruder_model) wf⇩t⇩r⇩m⇩s_trms⇩s⇩s⇩t_subst:
assumes "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A ⋅⇩s⇩e⇩t δ)"
shows "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t (A ⋅⇩s⇩s⇩t δ))"
using assms
proof (induction A)
case (Cons a A)
hence IH: "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t (A ⋅⇩s⇩s⇩t δ))" and *: "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t⇩p a ⋅⇩s⇩e⇩t δ)" by auto
have "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ))" by (rule wf⇩t⇩r⇩m⇩s_trms⇩s⇩s⇩t⇩p_subst[OF *])
thus ?case using IH trms⇩s⇩s⇩t_subst_cons[of a A δ] by blast
qed simp
lemma fv⇩s⇩s⇩t_subst_obtain_var:
assumes "x ∈ fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t δ)"
shows "∃y ∈ fv⇩s⇩s⇩t S. x ∈ fv (δ y)"
using assms
proof (induction S)
case (Cons s S)
hence "x ∈ fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t δ) ⟹ ∃y ∈ fv⇩s⇩s⇩t S. x ∈ fv (δ y)"
using bvars⇩s⇩s⇩t_cons_subset[of S s]
by blast
thus ?case
proof (cases "x ∈ fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t δ)")
case False
hence *: "x ∈ fv⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p δ)"
using Cons.prems(1) subst_sst_cons[of s S δ]
by fastforce
have "∃y ∈ fv⇩s⇩s⇩t⇩p s. x ∈ fv (δ y)"
proof (cases s)
case (NegChecks X F G)
hence "x ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ) ∨ x ∈ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ)"
and **: "x ∉ set X"
using * by simp_all
then obtain y where y: "y ∈ fv⇩p⇩a⇩i⇩r⇩s F ∨ y ∈ fv⇩p⇩a⇩i⇩r⇩s G" "x ∈ fv ((rm_vars (set X) δ) y)"
using fv⇩p⇩a⇩i⇩r⇩s_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
by blast
have "y ∉ set X"
proof
assume y_in: "y ∈ set X"
hence "(rm_vars (set X) δ) y = Var y" by auto
hence "x = y" using y(2) by simp
thus False using ** y_in by metis
qed
thus ?thesis using NegChecks y by auto
qed (use * fv_subst_obtain_var in force)+
thus ?thesis by auto
qed auto
qed simp
lemma fv⇩s⇩s⇩t_subst_subset_range_vars_if_subset_domain:
assumes "fv⇩s⇩s⇩t S ⊆ subst_domain σ"
shows "fv⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t σ) ⊆ range_vars σ"
using assms fv⇩s⇩s⇩t_subst_obtain_var[of _ S σ] subst_dom_vars_in_subst[of _ σ] subst_fv_imgI[of σ]
by (metis (no_types) in_mono subsetI)
lemma fv⇩s⇩s⇩t_in_fv_trms⇩s⇩s⇩t: "x ∈ fv⇩s⇩s⇩t S ⟹ x ∈ fv⇩s⇩e⇩t (trms⇩s⇩s⇩t S)"
proof (induction S)
case (Cons s S) thus ?case
proof (cases "x ∈ fv⇩s⇩s⇩t S")
case False
hence *: "x ∈ fv⇩s⇩s⇩t⇩p s" using Cons.prems by simp
hence "x ∈ fv⇩s⇩e⇩t (trms⇩s⇩s⇩t⇩p s)"
proof (cases s)
case (NegChecks X F G)
hence "x ∈ fv⇩p⇩a⇩i⇩r⇩s F ∨ x ∈ fv⇩p⇩a⇩i⇩r⇩s G" using * by simp_all
thus ?thesis using * fv⇩p⇩a⇩i⇩r⇩s_in_fv_trms⇩p⇩a⇩i⇩r⇩s[of x] NegChecks by auto
qed auto
thus ?thesis by simp
qed simp
qed simp
lemma stateful_strand_step_subst_comp:
assumes "range_vars δ ∩ set (bvars⇩s⇩s⇩t⇩p x) = {}"
shows "x ⋅⇩s⇩s⇩t⇩p δ ∘⇩s θ = (x ⋅⇩s⇩s⇩t⇩p δ) ⋅⇩s⇩s⇩t⇩p θ"
proof (cases x)
case (NegChecks X F G)
hence *: "range_vars δ ∩ set X = {}" using assms by simp
have "H ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) (δ ∘⇩s θ) = (H ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ) ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ" for H
using pairs_subst_comp rm_vars_comp[OF *] by (induct H) (auto simp add: subst_apply_pairs_def)
thus ?thesis using NegChecks by simp
qed simp_all
lemma stateful_strand_subst_comp:
assumes "range_vars δ ∩ bvars⇩s⇩s⇩t S = {}"
shows "S ⋅⇩s⇩s⇩t δ ∘⇩s θ = (S ⋅⇩s⇩s⇩t δ) ⋅⇩s⇩s⇩t θ"
using assms
proof (induction S)
case (Cons s S)
hence IH: "S ⋅⇩s⇩s⇩t δ ∘⇩s θ = (S ⋅⇩s⇩s⇩t δ) ⋅⇩s⇩s⇩t θ" using Cons by auto
have "s ⋅⇩s⇩s⇩t⇩p δ ∘⇩s θ = (s ⋅⇩s⇩s⇩t⇩p δ) ⋅⇩s⇩s⇩t⇩p θ"
using Cons.prems stateful_strand_step_subst_comp[of δ s θ]
unfolding range_vars_alt_def by auto
thus ?case using IH by (simp add: subst_apply_stateful_strand_def)
qed simp
lemma subst_apply_bvars_disj_NegChecks:
assumes "set X ∩ subst_domain θ = {}"
shows "NegChecks X F G ⋅⇩s⇩s⇩t⇩p θ = NegChecks X (F ⋅⇩p⇩a⇩i⇩r⇩s θ) (G ⋅⇩p⇩a⇩i⇩r⇩s θ)"
proof -
have "rm_vars (set X) θ = θ" using assms rm_vars_apply'[of θ "set X"] by auto
thus ?thesis by simp
qed
lemma subst_apply_NegChecks_no_bvars[simp]:
"∀[]⟨∨≠: F ∨∉: F'⟩ ⋅⇩s⇩s⇩t⇩p θ = ∀[]⟨∨≠: (F ⋅⇩p⇩a⇩i⇩r⇩s θ) ∨∉: (F' ⋅⇩p⇩a⇩i⇩r⇩s θ)⟩"
"∀[]⟨∨≠: [] ∨∉: F'⟩ ⋅⇩s⇩s⇩t⇩p θ = ∀[]⟨∨≠: [] ∨∉: (F' ⋅⇩p⇩a⇩i⇩r⇩s θ)⟩"
"∀[]⟨∨≠: F ∨∉: []⟩ ⋅⇩s⇩s⇩t⇩p θ = ∀[]⟨∨≠: (F ⋅⇩p⇩a⇩i⇩r⇩s θ) ∨∉: []⟩"
"∀[]⟨∨≠: [] ∨∉: [(t,s)]⟩ ⋅⇩s⇩s⇩t⇩p θ = ∀[]⟨∨≠: [] ∨∉: ([(t ⋅ θ,s ⋅ θ)])⟩" (is ?A)
"∀[]⟨∨≠: [(t,s)] ∨∉: []⟩ ⋅⇩s⇩s⇩t⇩p θ = ∀[]⟨∨≠: ([(t ⋅ θ,s ⋅ θ)]) ∨∉: []⟩" (is ?B)
by simp_all
lemma setops⇩s⇩s⇩t_mono:
"set M ⊆ set N ⟹ setops⇩s⇩s⇩t M ⊆ setops⇩s⇩s⇩t N"
by (auto simp add: setops⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t_nil[simp]: "setops⇩s⇩s⇩t [] = {}"
by (simp add: setops⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t_cons[simp]: "setops⇩s⇩s⇩t (a#A) = setops⇩s⇩s⇩t⇩p a ∪ setops⇩s⇩s⇩t A"
by (simp add: setops⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t_cons_subset[simp]: "setops⇩s⇩s⇩t A ⊆ setops⇩s⇩s⇩t (a#A)"
using setops⇩s⇩s⇩t_cons[of a A] by blast
lemma setops⇩s⇩s⇩t_append: "setops⇩s⇩s⇩t (A@B) = setops⇩s⇩s⇩t A ∪ setops⇩s⇩s⇩t B"
proof (induction A)
case (Cons a A) thus ?case by (cases a) (auto simp add: setops⇩s⇩s⇩t_def)
qed (simp add: setops⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t⇩p_member_iff:
"(t,s) ∈ setops⇩s⇩s⇩t⇩p x ⟷
(x = Insert t s ∨ x = Delete t s ∨ (∃ac. x = InSet ac t s) ∨
(∃X F F'. x = NegChecks X F F' ∧ (t,s) ∈ set F'))"
by (cases x) auto
lemma setops⇩s⇩s⇩t_member_iff:
"(t,s) ∈ setops⇩s⇩s⇩t A ⟷
(Insert t s ∈ set A ∨ Delete t s ∈ set A ∨ (∃ac. InSet ac t s ∈ set A) ∨
(∃X F F'. NegChecks X F F' ∈ set A ∧ (t,s) ∈ set F'))"
(is "?P ⟷ ?Q")
proof (induction A)
case (Cons a A) thus ?case
proof (cases "(t, s) ∈ setops⇩s⇩s⇩t⇩p a")
case True thus ?thesis using setops⇩s⇩s⇩t⇩p_member_iff[of t s a] by auto
qed auto
qed simp
lemma setops⇩s⇩s⇩t⇩p_subst:
assumes "set (bvars⇩s⇩s⇩t⇩p a) ∩ subst_domain θ = {}"
shows "setops⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p θ) = setops⇩s⇩s⇩t⇩p a ⋅⇩p⇩s⇩e⇩t θ"
proof (cases a)
case (NegChecks X F G)
hence "rm_vars (set X) θ = θ" using assms rm_vars_apply'[of θ "set X"] by auto
hence "setops⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p θ) = set (G ⋅⇩p⇩a⇩i⇩r⇩s θ)"
"setops⇩s⇩s⇩t⇩p a ⋅⇩p⇩s⇩e⇩t θ = set G ⋅⇩p⇩s⇩e⇩t θ"
using NegChecks image_Un by simp_all
thus ?thesis by (simp add: subst_apply_pairs_def)
qed simp_all
lemma setops⇩s⇩s⇩t⇩p_subst':
assumes "¬is_NegChecks a"
shows "setops⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p θ) = setops⇩s⇩s⇩t⇩p a ⋅⇩p⇩s⇩e⇩t θ"
using assms by (cases a) auto
lemma setops⇩s⇩s⇩t⇩p_subst'':
fixes t::"('a,'b) term × ('a,'b) term" and δ::"('a,'b) subst"
assumes t: "t ∈ setops⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ)"
shows "∃s ∈ setops⇩s⇩s⇩t⇩p b. t = s ⋅⇩p rm_vars (set (bvars⇩s⇩s⇩t⇩p b)) δ"
proof (cases "is_NegChecks b")
case True
then obtain X F G where b: "b = NegChecks X F G" by (cases b) moura+
hence "setops⇩s⇩s⇩t⇩p b = set G" "setops⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) = set (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set (bvars⇩s⇩s⇩t⇩p b)) δ)"
by simp_all
thus ?thesis using t subst_apply_pairs_pset_subst[of G] by blast
next
case False
hence "setops⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) = setops⇩s⇩s⇩t⇩p b ⋅⇩p⇩s⇩e⇩t rm_vars (set (bvars⇩s⇩s⇩t⇩p b)) δ"
using setops⇩s⇩s⇩t⇩p_subst' bvars⇩s⇩s⇩t⇩p_NegChecks by fastforce
thus ?thesis using t by blast
qed
lemma setops⇩s⇩s⇩t_subst:
assumes "bvars⇩s⇩s⇩t S ∩ subst_domain θ = {}"
shows "setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ) = setops⇩s⇩s⇩t S ⋅⇩p⇩s⇩e⇩t θ"
using assms
proof (induction S)
case (Cons a S)
have "bvars⇩s⇩s⇩t S ∩ subst_domain θ = {}" and *: "set (bvars⇩s⇩s⇩t⇩p a) ∩ subst_domain θ = {}"
using Cons.prems by auto
hence IH: "setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ) = setops⇩s⇩s⇩t S ⋅⇩p⇩s⇩e⇩t θ"
using Cons.IH by auto
show ?case
using setops⇩s⇩s⇩t⇩p_subst[OF *] IH unfolding setops⇩s⇩s⇩t_def
by (auto simp add: subst_apply_stateful_strand_def)
qed (simp add: setops⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t_subst':
fixes p::"('a,'b) term × ('a,'b) term" and δ::"('a,'b) subst"
assumes "p ∈ setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t δ)"
shows "∃s ∈ setops⇩s⇩s⇩t S. ∃X. set X ⊆ bvars⇩s⇩s⇩t S ∧ p = s ⋅⇩p rm_vars (set X) δ"
using assms
proof (induction S)
case (Cons a S)
note 0 = setops⇩s⇩s⇩t_cons[of a S] bvars⇩s⇩s⇩t_Cons[of a S]
note 1 = setops⇩s⇩s⇩t_cons[of "a ⋅⇩s⇩s⇩t⇩p δ" "S ⋅⇩s⇩s⇩t δ"] subst_sst_cons[of a S δ]
have "p ∈ setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t δ) ∨ p ∈ setops⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ)" using Cons.prems 1 by auto
thus ?case
proof
assume *: "p ∈ setops⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ)"
show ?thesis using setops⇩s⇩s⇩t⇩p_subst''[OF *] 0 by blast
next
assume *: "p ∈ setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t δ)"
show ?thesis using Cons.IH[OF *] 0 by blast
qed
qed simp
subsection ‹Stateful Constraint Semantics›
context intruder_model
begin
definition negchecks_model where
"negchecks_model (ℐ::('a,'b) subst) (D::('a,'b) dbstate) X F G ≡
(∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶
(list_ex (λf. fst f ⋅ (δ ∘⇩s ℐ) ≠ snd f ⋅ (δ ∘⇩s ℐ)) F ∨
list_ex (λf. f ⋅⇩p (δ ∘⇩s ℐ) ∉ D) G))"
fun strand_sem_stateful::
"('fun,'var) terms ⇒ ('fun,'var) dbstate ⇒ ('fun,'var) stateful_strand ⇒ ('fun,'var) subst ⇒ bool"
("⟦_; _; _⟧⇩s")
where
"⟦M; D; []⟧⇩s = (λℐ. True)"
| "⟦M; D; Send t#S⟧⇩s = (λℐ. M ⊢ t ⋅ ℐ ∧ ⟦M; D; S⟧⇩s ℐ)"
| "⟦M; D; Receive t#S⟧⇩s = (λℐ. ⟦insert (t ⋅ ℐ) M; D; S⟧⇩s ℐ)"
| "⟦M; D; Equality _ t t'#S⟧⇩s = (λℐ. t ⋅ ℐ = t' ⋅ ℐ ∧ ⟦M; D; S⟧⇩s ℐ)"
| "⟦M; D; Insert t s#S⟧⇩s = (λℐ. ⟦M; insert ((t,s) ⋅⇩p ℐ) D; S⟧⇩s ℐ)"
| "⟦M; D; Delete t s#S⟧⇩s = (λℐ. ⟦M; D - {(t,s) ⋅⇩p ℐ}; S⟧⇩s ℐ)"
| "⟦M; D; InSet _ t s#S⟧⇩s = (λℐ. (t,s) ⋅⇩p ℐ ∈ D ∧ ⟦M; D; S⟧⇩s ℐ)"
| "⟦M; D; NegChecks X F F'#S⟧⇩s = (λℐ. negchecks_model ℐ D X F F' ∧ ⟦M; D; S⟧⇩s ℐ)"
lemmas strand_sem_stateful_induct =
strand_sem_stateful.induct[case_names Nil ConsSnd ConsRcv ConsEq
ConsIns ConsDel ConsIn ConsNegChecks]
abbreviation constr_sem_stateful (infix "⊨⇩s" 91) where "ℐ ⊨⇩s A ≡ ⟦{}; {}; A⟧⇩s ℐ"
lemma stateful_strand_sem_NegChecks_no_bvars:
"⟦M; D; [⟨t not in s⟩]⟧⇩s ℐ ⟹ (t ⋅ ℐ, s ⋅ ℐ) ∉ D"
"⟦M; D; [⟨t != s⟩]⟧⇩s ℐ ⟹ t ⋅ ℐ ≠ s ⋅ ℐ"
by (simp_all add: negchecks_model_def empty_dom_iff_empty_subst)
lemma strand_sem_ik_mono_stateful:
"⟦M; D; A⟧⇩s ℐ ⟹ ⟦M ∪ M'; D; A⟧⇩s ℐ"
using ideduct_mono by (induct A arbitrary: M M' D rule: strand_sem_stateful.induct) force+
lemma strand_sem_append_stateful:
"⟦M; D; A@B⟧⇩s ℐ ⟷ ⟦M; D; A⟧⇩s ℐ ∧ ⟦M ∪ (ik⇩s⇩s⇩t A ⋅⇩s⇩e⇩t ℐ); dbupd⇩s⇩s⇩t A ℐ D; B⟧⇩s ℐ"
(is "?P ⟷ ?Q ∧ ?R")
proof -
have 1: "?P ⟹ ?Q" by (induct A rule: strand_sem_stateful.induct) auto
have 2: "?P ⟹ ?R"
proof (induction A arbitrary: M D B)
case (Cons a A) thus ?case
proof (cases a)
case (Receive t)
have "insert (t ⋅ ℐ) (M ∪ (ik⇩s⇩s⇩t A ⋅⇩s⇩e⇩t ℐ)) = M ∪ (ik⇩s⇩s⇩t (a#A) ⋅⇩s⇩e⇩t ℐ)"
"dbupd⇩s⇩s⇩t A ℐ D = dbupd⇩s⇩s⇩t (a#A) ℐ D"
using Receive by (auto simp add: ik⇩s⇩s⇩t_def)
thus ?thesis using Cons Receive by force
qed (auto simp add: ik⇩s⇩s⇩t_def)
qed (simp add: ik⇩s⇩s⇩t_def)
have 3: "?Q ⟹ ?R ⟹ ?P"
proof (induction A arbitrary: M D)
case (Cons a A) thus ?case
proof (cases a)
case (Receive t)
have "insert (t ⋅ ℐ) (M ∪ (ik⇩s⇩s⇩t A ⋅⇩s⇩e⇩t ℐ)) = M ∪ (ik⇩s⇩s⇩t (a#A) ⋅⇩s⇩e⇩t ℐ)"
"dbupd⇩s⇩s⇩t A ℐ D = dbupd⇩s⇩s⇩t (a#A) ℐ D"
using Receive by (auto simp add: ik⇩s⇩s⇩t_def)
thus ?thesis using Cons Receive by simp
qed (auto simp add: ik⇩s⇩s⇩t_def)
qed (simp add: ik⇩s⇩s⇩t_def)
show ?thesis by (metis 1 2 3)
qed
lemma negchecks_model_db_subset:
fixes F F'::"(('a,'b) term × ('a,'b) term) list"
assumes "D' ⊆ D"
and "negchecks_model ℐ D X F F'"
shows "negchecks_model ℐ D' X F F'"
proof -
have "list_ex (λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D') F'"
when "list_ex (λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D) F'"
for δ::"('a,'b) subst"
using Bex_set[of F' "λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D'"]
Bex_set[of F' "λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D"]
that assms(1)
by blast
thus ?thesis using assms(2) by (auto simp add: negchecks_model_def)
qed
lemma negchecks_model_db_supset:
fixes F F'::"(('a,'b) term × ('a,'b) term) list"
assumes "D' ⊆ D"
and "∀f ∈ set F'. ∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶ f ⋅⇩p (δ ∘⇩s ℐ) ∉ D - D'"
and "negchecks_model ℐ D' X F F'"
shows "negchecks_model ℐ D X F F'"
proof -
have "list_ex (λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D) F'"
when "list_ex (λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D') F'" "subst_domain δ = set X ∧ ground (subst_range δ)"
for δ::"('a,'b) subst"
using Bex_set[of F' "λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D'"]
Bex_set[of F' "λf. f ⋅⇩p δ ∘⇩s ℐ ∉ D"]
that assms(1,2)
by blast
thus ?thesis using assms(3) by (auto simp add: negchecks_model_def)
qed
lemma negchecks_model_subst:
fixes F F'::"(('a,'b) term × ('a,'b) term) list"
assumes "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
shows "negchecks_model (δ ∘⇩s θ) D X F F' ⟷ negchecks_model θ D X (F ⋅⇩p⇩a⇩i⇩r⇩s δ) (F' ⋅⇩p⇩a⇩i⇩r⇩s δ)"
proof -
have 0: "σ ∘⇩s (δ ∘⇩s θ) = δ ∘⇩s (σ ∘⇩s θ)"
when σ: "subst_domain σ = set X" "ground (subst_range σ)" for σ
by (metis (no_types, lifting) σ subst_compose_assoc assms(1) inf_sup_aci(1)
subst_comp_eq_if_disjoint_vars sup_inf_absorb range_vars_alt_def)
{ fix σ::"('a,'b) subst" and t t'
assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
and *: "list_ex (λf. fst f ⋅ (σ ∘⇩s (δ ∘⇩s θ)) ≠ snd f ⋅ (σ ∘⇩s (δ ∘⇩s θ))) F"
obtain f where f: "f ∈ set F" "fst f ⋅ σ ∘⇩s (δ ∘⇩s θ) ≠ snd f ⋅ σ ∘⇩s (δ ∘⇩s θ)"
using * by (induct F) auto
hence "(fst f ⋅ δ) ⋅ σ ∘⇩s θ ≠ (snd f ⋅ δ) ⋅ σ ∘⇩s θ" using 0[OF σ] by simp
moreover have "(fst f ⋅ δ, snd f ⋅ δ) ∈ set (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using f(1) by (auto simp add: subst_apply_pairs_def)
ultimately have "list_ex (λf. fst f ⋅ (σ ∘⇩s θ) ≠ snd f ⋅ (σ ∘⇩s θ)) (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using f(1) Bex_set by fastforce
} moreover {
fix σ::"('a,'b) subst" and t t'
assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
and *: "list_ex (λf. f ⋅⇩p σ ∘⇩s (δ ∘⇩s θ) ∉ D) F'"
obtain f where f: "f ∈ set F'" "f ⋅⇩p σ ∘⇩s (δ ∘⇩s θ) ∉ D"
using * by (induct F') auto
hence "f ⋅⇩p δ ⋅⇩p σ ∘⇩s θ ∉ D" using 0[OF σ] by (metis subst_pair_compose)
moreover have "f ⋅⇩p δ ∈ set (F' ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using f(1) by (auto simp add: subst_apply_pairs_def)
ultimately have "list_ex (λf. f ⋅⇩p σ ∘⇩s θ ∉ D) (F' ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using f(1) Bex_set by fastforce
} moreover {
fix σ::"('a,'b) subst" and t t'
assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
and *: "list_ex (λf. fst f ⋅ (σ ∘⇩s θ) ≠ snd f ⋅ (σ ∘⇩s θ)) (F ⋅⇩p⇩a⇩i⇩r⇩s δ)"
obtain f where f: "f ∈ set (F ⋅⇩p⇩a⇩i⇩r⇩s δ)" "fst f ⋅ σ ∘⇩s θ ≠ snd f ⋅ σ ∘⇩s θ"
using * by (induct F) (auto simp add: subst_apply_pairs_def)
then obtain g where g: "g ∈ set F" "f = g ⋅⇩p δ" by (auto simp add: subst_apply_pairs_def)
have "fst g ⋅ σ ∘⇩s (δ ∘⇩s θ) ≠ snd g ⋅ σ ∘⇩s (δ ∘⇩s θ)"
using f(2) g 0[OF σ] by (simp add: prod.case_eq_if)
hence "list_ex (λf. fst f ⋅ (σ ∘⇩s (δ ∘⇩s θ)) ≠ snd f ⋅ (σ ∘⇩s (δ ∘⇩s θ))) F"
using g Bex_set by fastforce
} moreover {
fix σ::"('a,'b) subst" and t t'
assume σ: "subst_domain σ = set X" "ground (subst_range σ)"
and *: "list_ex (λf. f ⋅⇩p (σ ∘⇩s θ) ∉ D) (F' ⋅⇩p⇩a⇩i⇩r⇩s δ)"
obtain f where f: "f ∈ set (F' ⋅⇩p⇩a⇩i⇩r⇩s δ)" "f ⋅⇩p σ ∘⇩s θ ∉ D"
using * by (induct F') (auto simp add: subst_apply_pairs_def)
then obtain g where g: "g ∈ set F'" "f = g ⋅⇩p δ" by (auto simp add: subst_apply_pairs_def)
have "g ⋅⇩p σ ∘⇩s (δ ∘⇩s θ) ∉ D"
using f(2) g 0[OF σ] by (simp add: prod.case_eq_if)
hence "list_ex (λf. f ⋅⇩p (σ ∘⇩s (δ ∘⇩s θ)) ∉ D) F'"
using g Bex_set by fastforce
} ultimately show ?thesis using assms unfolding negchecks_model_def by blast
qed
lemma strand_sem_subst_stateful:
fixes δ::"('fun,'var) subst"
assumes "(subst_domain δ ∪ range_vars δ) ∩ bvars⇩s⇩s⇩t S = {}"
shows "⟦M; D; S⟧⇩s (δ ∘⇩s θ) ⟷ ⟦M; D; S ⋅⇩s⇩s⇩t δ⟧⇩s θ"
proof
note [simp] = subst_sst_cons[of _ _ δ] subst_subst_compose[of _ δ θ]
have "(subst_domain δ ∪ range_vars δ) ∩ (subst_domain γ ∪ range_vars γ) = {}"
when δ: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
and γ: "subst_domain γ = set X" "ground (subst_range γ)"
for X and γ::"('fun,'var) subst"
using δ γ unfolding range_vars_alt_def by auto
hence 0: "γ ∘⇩s δ = δ ∘⇩s γ"
when δ: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
and γ: "subst_domain γ = set X" "ground (subst_range γ)"
for γ X
by (metis δ γ subst_comp_eq_if_disjoint_vars)
show "⟦M; D; S⟧⇩s (δ ∘⇩s θ) ⟹ ⟦M; D; S ⋅⇩s⇩s⇩t δ⟧⇩s θ" using assms
proof (induction S arbitrary: M D rule: strand_sem_stateful_induct)
case (ConsNegChecks M D X F F' S)
hence *: "⟦M; D; S ⋅⇩s⇩s⇩t δ⟧⇩s θ" and **: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
unfolding bvars⇩s⇩s⇩t_def negchecks_model_def by (force, auto)
have "negchecks_model (δ ∘⇩s θ) D X F F'" using ConsNegChecks by auto
hence "negchecks_model θ D X (F ⋅⇩p⇩a⇩i⇩r⇩s δ) (F' ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using 0[OF **] negchecks_model_subst[OF **] by blast
moreover have "rm_vars (set X) δ = δ" using ConsNegChecks.prems(2) by force
ultimately show ?case using * by auto
qed simp_all
show "⟦M; D; S ⋅⇩s⇩s⇩t δ⟧⇩s θ ⟹ ⟦M; D; S⟧⇩s (δ ∘⇩s θ)" using assms
proof (induction S arbitrary: M D rule: strand_sem_stateful_induct)
case (ConsNegChecks M D X F F' S)
have δ: "rm_vars (set X) δ = δ" using ConsNegChecks.prems(2) by force
hence *: "⟦M; D; S⟧⇩s (δ ∘⇩s θ)" and **: "(subst_domain δ ∪ range_vars δ) ∩ set X = {}"
using ConsNegChecks unfolding bvars⇩s⇩s⇩t_def negchecks_model_def by auto
have "negchecks_model θ D X (F ⋅⇩p⇩a⇩i⇩r⇩s δ) (F' ⋅⇩p⇩a⇩i⇩r⇩s δ)"
using ConsNegChecks.prems(1) δ by (auto simp add: subst_compose_assoc negchecks_model_def)
hence "negchecks_model (δ ∘⇩s θ) D X F F'"
using 0[OF **] negchecks_model_subst[OF **] by blast
thus ?case using * by auto
qed simp_all
qed
end
subsection ‹Well-Formedness Lemmata›
lemma wfvarsocc⇩s⇩s⇩t_subset_wfrestrictedvars⇩s⇩s⇩t[simp]:
"wfvarsoccs⇩s⇩s⇩t S ⊆ wfrestrictedvars⇩s⇩s⇩t S"
by (induction S)
(auto simp add: wfrestrictedvars⇩s⇩s⇩t_def wfvarsoccs⇩s⇩s⇩t_def
split: stateful_strand_step.split poscheckvariant.split)
lemma wfvarsoccs⇩s⇩s⇩t_append: "wfvarsoccs⇩s⇩s⇩t (S@S') = wfvarsoccs⇩s⇩s⇩t S ∪ wfvarsoccs⇩s⇩s⇩t S'"
by (simp add: wfvarsoccs⇩s⇩s⇩t_def)
lemma wfrestrictedvars⇩s⇩s⇩t_union[simp]:
"wfrestrictedvars⇩s⇩s⇩t (S@T) = wfrestrictedvars⇩s⇩s⇩t S ∪ wfrestrictedvars⇩s⇩s⇩t T"
by (simp add: wfrestrictedvars⇩s⇩s⇩t_def)
lemma wfrestrictedvars⇩s⇩s⇩t_singleton:
"wfrestrictedvars⇩s⇩s⇩t [s] = wfrestrictedvars⇩s⇩s⇩t⇩p s"
by (simp add: wfrestrictedvars⇩s⇩s⇩t_def)
lemma wf⇩s⇩s⇩t_prefix[dest]: "wf'⇩s⇩s⇩t V (S@S') ⟹ wf'⇩s⇩s⇩t V S"
by (induct S rule: wf'⇩s⇩s⇩t.induct) auto
lemma wf⇩s⇩s⇩t_vars_mono: "wf'⇩s⇩s⇩t V S ⟹ wf'⇩s⇩s⇩t (V ∪ W) S"
proof (induction S arbitrary: V)
case (Cons x S) thus ?case
proof (cases x)
case (Send t)
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ W) S" using Cons.prems(1) Cons.IH by simp
thus ?thesis using Send by (simp add: sup_commute sup_left_commute)
next
case (Equality a t t')
show ?thesis
proof (cases a)
case Assign
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ W) S" "fv t' ⊆ V ∪ W" using Equality Cons.prems(1) Cons.IH by auto
thus ?thesis using Equality Assign by (simp add: sup_commute sup_left_commute)
next
case Check thus ?thesis using Equality Cons by auto
qed
next
case (InSet a t t')
show ?thesis
proof (cases a)
case Assign
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ fv t' ∪ W) S" using InSet Cons.prems(1) Cons.IH by auto
thus ?thesis using InSet Assign by (simp add: sup_commute sup_left_commute)
next
case Check thus ?thesis using InSet Cons by auto
qed
qed auto
qed simp
lemma wf⇩s⇩s⇩tI[intro]: "wfrestrictedvars⇩s⇩s⇩t S ⊆ V ⟹ wf'⇩s⇩s⇩t V S"
proof (induction S)
case (Cons x S) thus ?case
proof (cases x)
case (Send t)
hence "wf'⇩s⇩s⇩t V S" "V ∪ fv t = V"
using Cons
unfolding wfrestrictedvars⇩s⇩s⇩t_def
by auto
thus ?thesis using Send by simp
next
case (Equality a t t')
show ?thesis
proof (cases a)
case Assign
hence "wf'⇩s⇩s⇩t V S" "fv t' ⊆ V"
using Equality Cons
unfolding wfrestrictedvars⇩s⇩s⇩t_def
by auto
thus ?thesis using wf⇩s⇩s⇩t_vars_mono Equality Assign by simp
next
case Check
thus ?thesis
using Equality Cons
unfolding wfrestrictedvars⇩s⇩s⇩t_def
by auto
qed
next
case (InSet a t t')
show ?thesis
proof (cases a)
case Assign
hence "wf'⇩s⇩s⇩t V S" "fv t ∪ fv t' ⊆ V"
using InSet Cons
unfolding wfrestrictedvars⇩s⇩s⇩t_def
by auto
thus ?thesis using wf⇩s⇩s⇩t_vars_mono InSet Assign by (simp add: Un_assoc)
next
case Check
thus ?thesis
using InSet Cons
unfolding wfrestrictedvars⇩s⇩s⇩t_def
by auto
qed
qed (simp_all add: wfrestrictedvars⇩s⇩s⇩t_def)
qed (simp add: wfrestrictedvars⇩s⇩s⇩t_def)
lemma wf⇩s⇩s⇩tI'[intro]:
assumes "⋃((λx. case x of
Receive t ⇒ fv t
| Equality Assign _ t' ⇒ fv t'
| Insert t t' ⇒ fv t ∪ fv t'
| _ ⇒ {}) ` set S) ⊆ V"
shows "wf'⇩s⇩s⇩t V S"
using assms
proof (induction S)
case (Cons x S) thus ?case
proof (cases x)
case (Equality a t t')
thus ?thesis using Cons by (cases a) (auto simp add: wf⇩s⇩s⇩t_vars_mono)
next
case (InSet a t t')
thus ?thesis using Cons by (cases a) (auto simp add: wf⇩s⇩s⇩t_vars_mono Un_assoc)
qed (simp_all add: wf⇩s⇩s⇩t_vars_mono)
qed simp
lemma wf⇩s⇩s⇩t_append_exec: "wf'⇩s⇩s⇩t V (S@S') ⟹ wf'⇩s⇩s⇩t (V ∪ wfvarsoccs⇩s⇩s⇩t S) S'"
proof (induction S arbitrary: V)
case (Cons x S V) thus ?case
proof (cases x)
case (Send t)
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ wfvarsoccs⇩s⇩s⇩t S) S'" using Cons.prems Cons.IH by simp
thus ?thesis using Send unfolding wfvarsoccs⇩s⇩s⇩t_def by (auto simp add: sup_assoc)
next
case (Equality a t t') show ?thesis
proof (cases a)
case Assign
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ wfvarsoccs⇩s⇩s⇩t S) S'" using Equality Cons.prems Cons.IH by auto
thus ?thesis using Equality Assign unfolding wfvarsoccs⇩s⇩s⇩t_def by (auto simp add: sup_assoc)
next
case Check
hence "wf'⇩s⇩s⇩t (V ∪ wfvarsoccs⇩s⇩s⇩t S) S'" using Equality Cons.prems Cons.IH by auto
thus ?thesis using Equality Check unfolding wfvarsoccs⇩s⇩s⇩t_def by (auto simp add: sup_assoc)
qed
next
case (InSet a t t') show ?thesis
proof (cases a)
case Assign
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ fv t' ∪ wfvarsoccs⇩s⇩s⇩t S) S'" using InSet Cons.prems Cons.IH by auto
thus ?thesis using InSet Assign unfolding wfvarsoccs⇩s⇩s⇩t_def by (auto simp add: sup_assoc)
next
case Check
hence "wf'⇩s⇩s⇩t (V ∪ wfvarsoccs⇩s⇩s⇩t S) S'" using InSet Cons.prems Cons.IH by auto
thus ?thesis using InSet Check unfolding wfvarsoccs⇩s⇩s⇩t_def by (auto simp add: sup_assoc)
qed
qed (auto simp add: wfvarsoccs⇩s⇩s⇩t_def)
qed (simp add: wfvarsoccs⇩s⇩s⇩t_def)
lemma wf⇩s⇩s⇩t_append:
"wf'⇩s⇩s⇩t X S ⟹ wf'⇩s⇩s⇩t Y T ⟹ wf'⇩s⇩s⇩t (X ∪ Y) (S@T)"
proof (induction X S rule: wf'⇩s⇩s⇩t.induct)
case 1 thus ?case by (metis wf⇩s⇩s⇩t_vars_mono Un_commute append_Nil)
next
case 3 thus ?case by (metis append_Cons Un_commute Un_assoc wf'⇩s⇩s⇩t.simps(3))
next
case (4 V t t' S)
hence *: "fv t' ⊆ V" and "wf'⇩s⇩s⇩t (V ∪ fv t ∪ Y) (S @ T)" by simp_all
hence "wf'⇩s⇩s⇩t (V ∪ Y ∪ fv t) (S @ T)" by (metis Un_commute Un_assoc)
thus ?case using * by auto
next
case (8 V t t' S)
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ fv t' ∪ Y) (S @ T)" by simp_all
hence "wf'⇩s⇩s⇩t (V ∪ Y ∪ fv t ∪ fv t') (S @ T)" by (metis Un_commute Un_assoc)
thus ?case by auto
qed auto
lemma wf⇩s⇩s⇩t_append_suffix:
"wf'⇩s⇩s⇩t V S ⟹ wfrestrictedvars⇩s⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩s⇩t S ∪ V ⟹ wf'⇩s⇩s⇩t V (S@S')"
proof (induction V S rule: wf'⇩s⇩s⇩t.induct)
case (2 V t S)
hence *: "fv t ⊆ V" "wf'⇩s⇩s⇩t V S" by simp_all
hence "wfrestrictedvars⇩s⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩s⇩t S ∪ V"
using "2.prems"(2) unfolding wfrestrictedvars⇩s⇩s⇩t_def by auto
thus ?case using "2.IH" * by simp
next
case (3 V t S)
hence *: "wf'⇩s⇩s⇩t (V ∪ fv t) S" by simp_all
hence "wfrestrictedvars⇩s⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩s⇩t S ∪ (V ∪ fv t)"
using "3.prems"(2) unfolding wfrestrictedvars⇩s⇩s⇩t_def by auto
thus ?case using "3.IH" * by simp
next
case (4 V t t' S)
hence *: "fv t' ⊆ V" "wf'⇩s⇩s⇩t (V ∪ fv t) S" by simp_all
moreover have "vars⇩s⇩s⇩t⇩p (⟨t := t'⟩) = fv t ∪ fv t'"
by simp
moreover have "wfrestrictedvars⇩s⇩s⇩t (⟨t := t'⟩#S) = fv t ∪ fv t' ∪ wfrestrictedvars⇩s⇩s⇩t S"
unfolding wfrestrictedvars⇩s⇩s⇩t_def by auto
ultimately have "wfrestrictedvars⇩s⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩s⇩t S ∪ (V ∪ fv t)"
using "4.prems"(2) by blast
thus ?case using "4.IH" * by simp
next
case (6 V t t' S)
hence *: "fv t ∪ fv t' ⊆ V" "wf'⇩s⇩s⇩t V S" by simp_all
moreover have "vars⇩s⇩s⇩t⇩p (insert⟨t,t'⟩) = fv t ∪ fv t'"
by simp
moreover have "wfrestrictedvars⇩s⇩s⇩t (insert⟨t,t'⟩#S) = fv t ∪ fv t' ∪ wfrestrictedvars⇩s⇩s⇩t S"
unfolding wfrestrictedvars⇩s⇩s⇩t_def by auto
ultimately have "wfrestrictedvars⇩s⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩s⇩t S ∪ V"
using "6.prems"(2) by blast
thus ?case using "6.IH" * by simp
next
case (8 V t t' S)
hence *: "wf'⇩s⇩s⇩t (V ∪ fv t ∪ fv t') S" by simp_all
moreover have "vars⇩s⇩s⇩t⇩p (select⟨t,t'⟩) = fv t ∪ fv t'"
by simp
moreover have "wfrestrictedvars⇩s⇩s⇩t (select⟨t,t'⟩#S) = fv t ∪ fv t' ∪ wfrestrictedvars⇩s⇩s⇩t S"
unfolding wfrestrictedvars⇩s⇩s⇩t_def by auto
ultimately have "wfrestrictedvars⇩s⇩s⇩t S' ⊆ wfrestrictedvars⇩s⇩s⇩t S ∪ (V ∪ fv t ∪ fv t')"
using "8.prems"(2) by blast
thus ?case using "8.IH" * by simp
qed (simp_all add: wf⇩s⇩s⇩tI wfrestrictedvars⇩s⇩s⇩t_def)
lemma wf⇩s⇩s⇩t_append_suffix':
assumes "wf'⇩s⇩s⇩t V S"
and "⋃((λx. case x of
Receive t ⇒ fv t
| Equality Assign _ t' ⇒ fv t'
| Insert t t' ⇒ fv t ∪ fv t'
| _ ⇒ {}) ` set S') ⊆ wfvarsoccs⇩s⇩s⇩t S ∪ V"
shows "wf'⇩s⇩s⇩t V (S@S')"
using assms
by (induction V S rule: wf'⇩s⇩s⇩t.induct)
(auto simp add: wf⇩s⇩s⇩tI' wf⇩s⇩s⇩t_vars_mono wfvarsoccs⇩s⇩s⇩t_def)
lemma wf⇩s⇩s⇩t_subst_apply:
"wf'⇩s⇩s⇩t V S ⟹ wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (S ⋅⇩s⇩s⇩t δ)"
proof (induction S arbitrary: V rule: wf'⇩s⇩s⇩t.induct)
case (2 V t S)
hence "wf'⇩s⇩s⇩t V S" "fv t ⊆ V" by simp_all
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (S ⋅⇩s⇩s⇩t δ)" "fv (t ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V)"
using "2.IH" subst_apply_fv_subset by simp_all
thus ?case by (simp add: subst_apply_stateful_strand_def)
next
case (3 V t S)
hence "wf'⇩s⇩s⇩t (V ∪ fv t) S" by simp
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` (V ∪ fv t))) (S ⋅⇩s⇩s⇩t δ)" using "3.IH" by metis
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ)) (S ⋅⇩s⇩s⇩t δ)" by (metis subst_apply_fv_union)
thus ?case by (simp add: subst_apply_stateful_strand_def)
next
case (4 V t t' S)
hence "wf'⇩s⇩s⇩t (V ∪ fv t) S" "fv t' ⊆ V" by auto
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` (V ∪ fv t))) (S ⋅⇩s⇩s⇩t δ)" and *: "fv (t' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V)"
using "4.IH" subst_apply_fv_subset by force+
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ)) (S ⋅⇩s⇩s⇩t δ)" by (metis subst_apply_fv_union)
thus ?case using * by (simp add: subst_apply_stateful_strand_def)
next
case (6 V t t' S)
hence "wf'⇩s⇩s⇩t V S" "fv t ∪ fv t' ⊆ V" by auto
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` V)) (S ⋅⇩s⇩s⇩t δ)" "fv (t ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V)" "fv (t' ⋅ δ) ⊆ fv⇩s⇩e⇩t (δ ` V)"
using "6.IH" subst_apply_fv_subset by force+
thus ?case by (simp add: sup_assoc subst_apply_stateful_strand_def)
next
case (8 V t t' S)
hence "wf'⇩s⇩s⇩t (V ∪ fv t ∪ fv t') S" by auto
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` (V ∪ fv t ∪ fv t'))) (S ⋅⇩s⇩s⇩t δ)"
using "8.IH" subst_apply_fv_subset by force
hence "wf'⇩s⇩s⇩t (fv⇩s⇩e⇩t (δ ` V) ∪ fv (t ⋅ δ) ∪ fv (t' ⋅ δ)) (S ⋅⇩s⇩s⇩t δ)" by (metis subst_apply_fv_union)
thus ?case by (simp add: subst_apply_stateful_strand_def)
qed (auto simp add: subst_apply_stateful_strand_def)
end
Theory Stateful_Typing
section ‹Extending the Typing Result to Stateful Constraints›
text ‹\label{sec:Stateful-Typing}›
theory Stateful_Typing
imports Typing_Result Stateful_Strands
begin
text ‹Locale setup›
locale stateful_typed_model = typed_model arity public Ana Γ
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,'var) term ⇒ (('fun,'var) term list × ('fun,'var) term list)"
and Γ::"('fun,'var) term ⇒ ('fun,'atom::finite) term_type"
+
fixes Pair::"'fun"
assumes Pair_arity: "arity Pair = 2"
and Ana_subst': "⋀f T δ K M. Ana (Fun f T) = (K,M) ⟹ Ana (Fun f T ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ,M ⋅⇩l⇩i⇩s⇩t δ)"
begin
lemma Ana_invar_subst'[simp]: "Ana_invar_subst 𝒮"
using Ana_subst' unfolding Ana_invar_subst_def by force
definition pair where
"pair d ≡ case d of (t,t') ⇒ Fun Pair [t,t']"
fun tr⇩p⇩a⇩i⇩r⇩s::
"(('fun,'var) term × ('fun,'var) term) list ⇒
('fun,'var) dbstatelist ⇒
(('fun,'var) term × ('fun,'var) term) list list"
where
"tr⇩p⇩a⇩i⇩r⇩s [] D = [[]]"
| "tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F) D =
concat (map (λd. map ((#) (pair (s,t), pair d)) (tr⇩p⇩a⇩i⇩r⇩s F D)) D)"
text ‹
A translation/reduction ‹tr› from stateful constraints to (lists of) "non-stateful" constraints.
The output represents a finite disjunction of constraints whose models constitute exactly the
models of the input constraint. The typing result for "non-stateful" constraints is later lifted
to the stateful setting through this reduction procedure.
›
fun tr::"('fun,'var) stateful_strand ⇒ ('fun,'var) dbstatelist ⇒ ('fun,'var) strand list"
where
"tr [] D = [[]]"
| "tr (send⟨t⟩#A) D = map ((#) (send⟨t⟩⇩s⇩t)) (tr A D)"
| "tr (receive⟨t⟩#A) D = map ((#) (receive⟨t⟩⇩s⇩t)) (tr A D)"
| "tr (⟨ac: t ≐ t'⟩#A) D = map ((#) (⟨ac: t ≐ t'⟩⇩s⇩t)) (tr A D)"
| "tr (insert⟨t,s⟩#A) D = tr A (List.insert (t,s) D)"
| "tr (delete⟨t,s⟩#A) D =
concat (map (λDi. map (λB. (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di])@B)
(tr A [d←D. d ∉ set Di]))
(subseqs D))"
| "tr (⟨ac: t ∈ s⟩#A) D =
concat (map (λB. map (λd. ⟨ac: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t#B) D) (tr A D))"
| "tr (∀X⟨∨≠: F ∨∉: F'⟩#A) D =
map ((@) (map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D))) (tr A D)"
text ‹Type-flaw resistance of stateful constraint steps›
fun tfr⇩s⇩s⇩t⇩p where
"tfr⇩s⇩s⇩t⇩p (Equality _ t t') = ((∃δ. Unifier δ t t') ⟶ Γ t = Γ t')"
| "tfr⇩s⇩s⇩t⇩p (NegChecks X F F') = (
(F' = [] ∧ (∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F-set X. ∃a. Γ (Var x) = TAtom a)) ∨
(∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') ⟶
T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X)))"
| "tfr⇩s⇩s⇩t⇩p _ = True"
text ‹Type-flaw resistance of stateful constraints›
definition tfr⇩s⇩s⇩t where "tfr⇩s⇩s⇩t S ≡ tfr⇩s⇩e⇩t (trms⇩s⇩s⇩t S ∪ pair ` setops⇩s⇩s⇩t S) ∧ list_all tfr⇩s⇩s⇩t⇩p S"
subsection ‹Small Lemmata›
lemma pair_in_pair_image_iff:
"pair (s,t) ∈ pair ` P ⟷ (s,t) ∈ P"
unfolding pair_def by fast
lemma subst_apply_pairs_pair_image_subst:
"pair ` set (F ⋅⇩p⇩a⇩i⇩r⇩s θ) = pair ` set F ⋅⇩s⇩e⇩t θ"
unfolding subst_apply_pairs_def pair_def by (induct F) auto
lemma Ana_subst_subterms_cases:
fixes θ::"('fun,'var) subst"
assumes t: "t ∈ subterms⇩s⇩e⇩t (M ⋅⇩s⇩e⇩t θ)"
and s: "s ∈ set (snd (Ana t))"
shows "(∃u ∈ subterms⇩s⇩e⇩t M. t = u ⋅ θ ∧ s ∈ set (snd (Ana u)) ⋅⇩s⇩e⇩t θ) ∨ (∃x ∈ fv⇩s⇩e⇩t M. t ⊑ θ x)"
proof (cases "t ∈ subterms⇩s⇩e⇩t M ⋅⇩s⇩e⇩t θ")
case True
then obtain u where u: "u ∈ subterms⇩s⇩e⇩t M" "t = u ⋅ θ" by moura
show ?thesis
proof (cases u)
case (Var x)
hence "x ∈ fv⇩s⇩e⇩t M" using fv_subset_subterms[OF u(1)] by simp
thus ?thesis using u(2) Var by fastforce
next
case (Fun f T)
hence "set (snd (Ana t)) = set (snd (Ana u)) ⋅⇩s⇩e⇩t θ"
using Ana_subst'[of f T _ _ θ] u(2) by (cases "Ana u") auto
thus ?thesis using s u by blast
qed
qed (use s t subterms⇩s⇩e⇩t_subst in blast)
lemma tfr⇩s⇩s⇩t⇩p_alt_def:
"list_all tfr⇩s⇩s⇩t⇩p S =
((∀ac t t'. Equality ac t t' ∈ set S ∧ (∃δ. Unifier δ t t') ⟶ Γ t = Γ t') ∧
(∀X F F'. NegChecks X F F' ∈ set S ⟶ (
(F' = [] ∧ (∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F-set X. ∃a. Γ (Var x) = TAtom a)) ∨
(∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') ⟶
T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X)))))"
(is "?P S = ?Q S")
proof
show "?P S ⟹ ?Q S"
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
show "?Q S ⟹ ?P S"
proof (induction S)
case (Cons x S) thus ?case by (cases x) auto
qed simp
qed
lemma fun_pair_eq[dest]: "pair d = pair d' ⟹ d = d'"
proof -
obtain t s t' s' where "d = (t,s)" "d' = (t',s')" by moura
thus "pair d = pair d' ⟹ d = d'" unfolding pair_def by simp
qed
lemma fun_pair_subst: "pair d ⋅ δ = pair (d ⋅⇩p δ)"
using surj_pair[of d] unfolding pair_def by force
lemma fun_pair_subst_set: "pair ` M ⋅⇩s⇩e⇩t δ = pair ` (M ⋅⇩p⇩s⇩e⇩t δ)"
proof
show "pair ` M ⋅⇩s⇩e⇩t δ ⊆ pair ` (M ⋅⇩p⇩s⇩e⇩t δ)"
using fun_pair_subst[of _ δ] by fastforce
show "pair ` (M ⋅⇩p⇩s⇩e⇩t δ) ⊆ pair ` M ⋅⇩s⇩e⇩t δ"
proof
fix t assume t: "t ∈ pair ` (M ⋅⇩p⇩s⇩e⇩t δ)"
then obtain p where p: "p ∈ M" "t = pair (p ⋅⇩p δ)" by blast
thus "t ∈ pair ` M ⋅⇩s⇩e⇩t δ" using fun_pair_subst[of p δ] by force
qed
qed
lemma fun_pair_eq_subst: "pair d ⋅ δ = pair d' ⋅ θ ⟷ d ⋅⇩p δ = d' ⋅⇩p θ"
by (metis fun_pair_subst fun_pair_eq[of "d ⋅⇩p δ" "d' ⋅⇩p θ"])
lemma setops⇩s⇩s⇩t_pair_image_cons[simp]:
"pair ` setops⇩s⇩s⇩t (x#S) = pair ` setops⇩s⇩s⇩t⇩p x ∪ pair ` setops⇩s⇩s⇩t S"
"pair ` setops⇩s⇩s⇩t (send⟨t⟩#S) = pair ` setops⇩s⇩s⇩t S"
"pair ` setops⇩s⇩s⇩t (receive⟨t⟩#S) = pair ` setops⇩s⇩s⇩t S"
"pair ` setops⇩s⇩s⇩t (⟨ac: t ≐ t'⟩#S) = pair ` setops⇩s⇩s⇩t S"
"pair ` setops⇩s⇩s⇩t (insert⟨t,s⟩#S) = {pair (t,s)} ∪ pair ` setops⇩s⇩s⇩t S"
"pair ` setops⇩s⇩s⇩t (delete⟨t,s⟩#S) = {pair (t,s)} ∪ pair ` setops⇩s⇩s⇩t S"
"pair ` setops⇩s⇩s⇩t (⟨ac: t ∈ s⟩#S) = {pair (t,s)} ∪ pair ` setops⇩s⇩s⇩t S"
"pair ` setops⇩s⇩s⇩t (∀X⟨∨≠: F ∨∉: G⟩#S) = pair ` set G ∪ pair ` setops⇩s⇩s⇩t S"
unfolding setops⇩s⇩s⇩t_def by auto
lemma setops⇩s⇩s⇩t_pair_image_subst_cons[simp]:
"pair ` setops⇩s⇩s⇩t (x#S ⋅⇩s⇩s⇩t θ) = pair ` setops⇩s⇩s⇩t⇩p (x ⋅⇩s⇩s⇩t⇩p θ) ∪ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
"pair ` setops⇩s⇩s⇩t (send⟨t⟩#S ⋅⇩s⇩s⇩t θ) = pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
"pair ` setops⇩s⇩s⇩t (receive⟨t⟩#S ⋅⇩s⇩s⇩t θ) = pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
"pair ` setops⇩s⇩s⇩t (⟨ac: t ≐ t'⟩#S ⋅⇩s⇩s⇩t θ) = pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
"pair ` setops⇩s⇩s⇩t (insert⟨t,s⟩#S ⋅⇩s⇩s⇩t θ) = {pair (t,s) ⋅ θ} ∪ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
"pair ` setops⇩s⇩s⇩t (delete⟨t,s⟩#S ⋅⇩s⇩s⇩t θ) = {pair (t,s) ⋅ θ} ∪ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
"pair ` setops⇩s⇩s⇩t (⟨ac: t ∈ s⟩#S ⋅⇩s⇩s⇩t θ) = {pair (t,s) ⋅ θ} ∪ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
"pair ` setops⇩s⇩s⇩t (∀X⟨∨≠: F ∨∉: G⟩#S ⋅⇩s⇩s⇩t θ) =
pair ` set (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∪ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using subst_sst_cons[of _ S θ] unfolding setops⇩s⇩s⇩t_def pair_def by auto
lemma setops⇩s⇩s⇩t_are_pairs: "t ∈ pair ` setops⇩s⇩s⇩t A ⟹ ∃s s'. t = pair (s,s')"
proof (induction A)
case (Cons a A) thus ?case
by (cases a) (auto simp add: setops⇩s⇩s⇩t_def)
qed (simp add: setops⇩s⇩s⇩t_def)
lemma fun_pair_wf⇩t⇩r⇩m: "wf⇩t⇩r⇩m t ⟹ wf⇩t⇩r⇩m t' ⟹ wf⇩t⇩r⇩m (pair (t,t'))"
using Pair_arity unfolding wf⇩t⇩r⇩m_def pair_def by auto
lemma wf⇩t⇩r⇩m⇩s_pairs: "wf⇩t⇩r⇩m⇩s (trms⇩p⇩a⇩i⇩r⇩s F) ⟹ wf⇩t⇩r⇩m⇩s (pair ` set F)"
using fun_pair_wf⇩t⇩r⇩m by blast
lemma tfr⇩s⇩s⇩t_Nil[simp]: "tfr⇩s⇩s⇩t []"
by (simp add: tfr⇩s⇩s⇩t_def setops⇩s⇩s⇩t_def)
lemma tfr⇩s⇩s⇩t_append: "tfr⇩s⇩s⇩t (A@B) ⟹ tfr⇩s⇩s⇩t A"
proof -
assume assms: "tfr⇩s⇩s⇩t (A@B)"
let ?M = "trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A"
let ?N = "trms⇩s⇩s⇩t (A@B) ∪ pair ` setops⇩s⇩s⇩t (A@B)"
let ?P = "λt t'. ∀x ∈ fv t ∪ fv t'. ∃a. Γ (Var x) = Var a"
let ?Q = "λX t t'. X = [] ∨ (∀x ∈ (fv t ∪ fv t')-set X. ∃a. Γ (Var x) = Var a)"
have *: "SMP ?M - Var`𝒱 ⊆ SMP ?N - Var`𝒱" "?M ⊆ ?N"
using SMP_mono[of ?M ?N] setops⇩s⇩s⇩t_append[of A B]
by auto
{ fix s t assume **: "tfr⇩s⇩e⇩t ?N" "s ∈ SMP ?M - Var`𝒱" "t ∈ SMP ?M - Var`𝒱" "(∃δ. Unifier δ s t)"
hence "s ∈ SMP ?N - Var`𝒱" "t ∈ SMP ?N - Var`𝒱" using * by auto
hence "Γ s = Γ t" using **(1,4) unfolding tfr⇩s⇩e⇩t_def by blast
} moreover have "∀t ∈ ?N. wf⇩t⇩r⇩m t ⟹ ∀t ∈ ?M. wf⇩t⇩r⇩m t" using * by blast
ultimately have "tfr⇩s⇩e⇩t ?N ⟹ tfr⇩s⇩e⇩t ?M" unfolding tfr⇩s⇩e⇩t_def by blast
hence "tfr⇩s⇩e⇩t ?M" using assms unfolding tfr⇩s⇩s⇩t_def by metis
thus "tfr⇩s⇩s⇩t A" using assms unfolding tfr⇩s⇩s⇩t_def by simp
qed
lemma tfr⇩s⇩s⇩t_append': "tfr⇩s⇩s⇩t (A@B) ⟹ tfr⇩s⇩s⇩t B"
proof -
assume assms: "tfr⇩s⇩s⇩t (A@B)"
let ?M = "trms⇩s⇩s⇩t B ∪ pair ` setops⇩s⇩s⇩t B"
let ?N = "trms⇩s⇩s⇩t (A@B) ∪ pair ` setops⇩s⇩s⇩t (A@B)"
let ?P = "λt t'. ∀x ∈ fv t ∪ fv t'. ∃a. Γ (Var x) = Var a"
let ?Q = "λX t t'. X = [] ∨ (∀x ∈ (fv t ∪ fv t')-set X. ∃a. Γ (Var x) = Var a)"
have *: "SMP ?M - Var`𝒱 ⊆ SMP ?N - Var`𝒱" "?M ⊆ ?N"
using SMP_mono[of ?M ?N] setops⇩s⇩s⇩t_append[of A B]
by auto
{ fix s t assume **: "tfr⇩s⇩e⇩t ?N" "s ∈ SMP ?M - Var`𝒱" "t ∈ SMP ?M - Var`𝒱" "(∃δ. Unifier δ s t)"
hence "s ∈ SMP ?N - Var`𝒱" "t ∈ SMP ?N - Var`𝒱" using * by auto
hence "Γ s = Γ t" using **(1,4) unfolding tfr⇩s⇩e⇩t_def by blast
} moreover have "∀t ∈ ?N. wf⇩t⇩r⇩m t ⟹ ∀t ∈ ?M. wf⇩t⇩r⇩m t" using * by blast
ultimately have "tfr⇩s⇩e⇩t ?N ⟹ tfr⇩s⇩e⇩t ?M" unfolding tfr⇩s⇩e⇩t_def by blast
hence "tfr⇩s⇩e⇩t ?M" using assms unfolding tfr⇩s⇩s⇩t_def by metis
thus "tfr⇩s⇩s⇩t B" using assms unfolding tfr⇩s⇩s⇩t_def by simp
qed
lemma tfr⇩s⇩s⇩t_cons: "tfr⇩s⇩s⇩t (a#A) ⟹ tfr⇩s⇩s⇩t A"
using tfr⇩s⇩s⇩t_append'[of "[a]" A] by simp
lemma tfr⇩s⇩s⇩t⇩p_subst:
assumes s: "tfr⇩s⇩s⇩t⇩p s"
and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "set (bvars⇩s⇩s⇩t⇩p s) ∩ range_vars θ = {}"
shows "tfr⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)"
proof (cases s)
case (Equality a t t')
thus ?thesis
proof (cases "∃δ. Unifier δ (t ⋅ θ) (t' ⋅ θ)")
case True
hence "∃δ. Unifier δ t t'" by (metis subst_subst_compose[of _ θ])
moreover have "Γ t = Γ (t ⋅ θ)" "Γ t' = Γ (t' ⋅ θ)" by (metis wt_subst_trm''[OF assms(2)])+
ultimately have "Γ (t ⋅ θ) = Γ (t' ⋅ θ)" using s Equality by simp
thus ?thesis using Equality True by simp
qed simp
next
case (NegChecks X F G)
let ?P = "λF G. G = [] ∧ (∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F-set X. ∃a. Γ (Var x) = TAtom a)"
let ?Q = "λF G. ∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set G) ⟶
T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X)"
let ?θ = "rm_vars (set X) θ"
have "?P F G ∨ ?Q F G" using NegChecks assms(1) by simp
hence "?P (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) (G ⋅⇩p⇩a⇩i⇩r⇩s ?θ) ∨ ?Q (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) (G ⋅⇩p⇩a⇩i⇩r⇩s ?θ)"
proof
assume *: "?P F G"
have "G ⋅⇩p⇩a⇩i⇩r⇩s ?θ = []" using * by simp
moreover have "∃a. Γ (Var x) = TAtom a" when x: "x ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) - set X" for x
proof -
obtain t t' where t: "(t,t') ∈ set (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ)" "x ∈ fv t ∪ fv t' - set X"
using x(1) by auto
then obtain u u' where u: "(u,u') ∈ set F" "u ⋅ ?θ = t" "u' ⋅ ?θ = t'"
unfolding subst_apply_pairs_def by auto
obtain y where y: "y ∈ fv u ∪ fv u' - set X" "x ∈ fv (?θ y)"
using t(2) u(2,3) rm_vars_fv_obtain by fast
hence a: "∃a. Γ (Var y) = TAtom a" using u * by auto
have a': "Γ (Var y) = Γ (?θ y)"
using wt_subst_trm''[OF wt_subst_rm_vars[OF θ(1), of "set X"], of "Var y"]
by simp
have "(∃z. ?θ y = Var z) ∨ (∃c. ?θ y = Fun c [])"
proof (cases "?θ y ∈ subst_range θ")
case True thus ?thesis
using a a' θ(2) const_type_inv_wf
by (cases "?θ y") fastforce+
qed fastforce
hence "?θ y = Var x" using y(2) by fastforce
hence "Γ (Var x) = Γ (Var y)" using a' by simp
thus ?thesis using a by presburger
qed
ultimately show ?thesis by simp
next
assume *: "?Q F G"
have **: "set X ∩ range_vars ?θ = {}"
using θ(3) NegChecks rm_vars_img_fv_subset[of "set X" θ] by auto
have "?Q (F ⋅⇩p⇩a⇩i⇩r⇩s ?θ) (G ⋅⇩p⇩a⇩i⇩r⇩s ?θ)"
using ineq_subterm_inj_cond_subst[OF ** *]
trms⇩p⇩a⇩i⇩r⇩s_subst[of F "rm_vars (set X) θ"]
subst_apply_pairs_pair_image_subst[of G "rm_vars (set X) θ"]
by (metis (no_types, lifting) image_Un)
thus ?thesis by simp
qed
thus ?thesis using NegChecks by simp
qed simp_all
lemma tfr⇩s⇩s⇩t⇩p_all_wt_subst_apply:
assumes S: "list_all tfr⇩s⇩s⇩t⇩p S"
and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "bvars⇩s⇩s⇩t S ∩ range_vars θ = {}"
shows "list_all tfr⇩s⇩s⇩t⇩p (S ⋅⇩s⇩s⇩t θ)"
proof -
have "set (bvars⇩s⇩s⇩t⇩p s) ∩ range_vars θ = {}" when "s ∈ set S" for s
using that θ(3) unfolding bvars⇩s⇩s⇩t_def range_vars_alt_def by fastforce
thus ?thesis
using tfr⇩s⇩s⇩t⇩p_subst[OF _ θ(1,2)] S
unfolding list_all_iff
by (auto simp add: subst_apply_stateful_strand_def)
qed
lemma tr⇩p⇩a⇩i⇩r⇩s_empty_case:
assumes "tr⇩p⇩a⇩i⇩r⇩s F D = []"
shows "D = []" "F ≠ []"
proof -
show "F ≠ []" using assms by (auto intro: ccontr)
have "tr⇩p⇩a⇩i⇩r⇩s F (a#A) ≠ []" for a A
by (induct F "a#A" rule: tr⇩p⇩a⇩i⇩r⇩s.induct) fastforce+
thus "D = []" using assms by (cases D) simp_all
qed
lemma tr⇩p⇩a⇩i⇩r⇩s_elem_length_eq:
assumes "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)"
shows "length G = length F"
using assms by (induct F D arbitrary: G rule: tr⇩p⇩a⇩i⇩r⇩s.induct) auto
lemma tr⇩p⇩a⇩i⇩r⇩s_index:
assumes "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)" "i < length F"
shows "∃d ∈ set D. G ! i = (pair (F ! i), pair d)"
using assms
proof (induction F D arbitrary: i G rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F D)
obtain d G' where G:
"d ∈ set D" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)"
"G = (pair (s,t), pair d)#G'"
using "2.prems"(1) by moura
show ?case
using "2.IH"[OF G(1,2)] "2.prems"(2) G(1,3)
by (cases i) auto
qed simp
lemma tr⇩p⇩a⇩i⇩r⇩s_cons:
assumes "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)" "d ∈ set D"
shows "(pair (s,t), pair d)#G ∈ set (tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F) D)"
using assms by auto
lemma tr⇩p⇩a⇩i⇩r⇩s_has_pair_lists:
assumes "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)" "g ∈ set G"
shows "∃f ∈ set F. ∃d ∈ set D. g = (pair f, pair d)"
using assms
proof (induction F D arbitrary: G rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F D)
obtain d G' where G:
"d ∈ set D" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)"
"G = (pair (s,t), pair d)#G'"
using "2.prems"(1) by moura
show ?case
using "2.IH"[OF G(1,2)] "2.prems"(2) G(1,3)
by (cases "g ∈ set G'") auto
qed simp
lemma tr⇩p⇩a⇩i⇩r⇩s_is_pair_lists:
assumes "f ∈ set F" "d ∈ set D"
shows "∃G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D). (pair f, pair d) ∈ set G"
(is "?P F D f d")
proof -
have "∀f ∈ set F. ∀d ∈ set D. ?P F D f d"
proof (induction F D rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F D)
hence IH: "∀f ∈ set F. ∀d ∈ set D. ?P F D f d" by metis
moreover have "∀d ∈ set D. ?P ((s,t)#F) D (s,t) d"
proof
fix d assume d: "d ∈ set D"
then obtain G where G: "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)"
using tr⇩p⇩a⇩i⇩r⇩s_empty_case(1) by force
hence "(pair (s, t), pair d)#G ∈ set (tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F) D)"
using d by auto
thus "?P ((s,t)#F) D (s,t) d" using d G by auto
qed
ultimately show ?case by fastforce
qed simp
thus ?thesis by (metis assms)
qed
lemma tr⇩p⇩a⇩i⇩r⇩s_db_append_subset:
"set (tr⇩p⇩a⇩i⇩r⇩s F D) ⊆ set (tr⇩p⇩a⇩i⇩r⇩s F (D@E))" (is ?A)
"set (tr⇩p⇩a⇩i⇩r⇩s F E) ⊆ set (tr⇩p⇩a⇩i⇩r⇩s F (D@E))" (is ?B)
proof -
show ?A
proof (induction F D rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F D)
show ?case
proof
fix G assume "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F) D)"
then obtain d G' where G':
"d ∈ set D" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)" "G = (pair (s,t), pair d)#G'"
by moura
have "d ∈ set (D@E)" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F (D@E))" using "2.IH"[OF G'(1)] G'(1,2) by auto
thus "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F) (D@E))" using G'(3) by auto
qed
qed simp
show ?B
proof (induction F E rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F E)
show ?case
proof
fix G assume "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F) E)"
then obtain d G' where G':
"d ∈ set E" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F E)" "G = (pair (s,t), pair d)#G'"
by moura
have "d ∈ set (D@E)" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F (D@E))" using "2.IH"[OF G'(1)] G'(1,2) by auto
thus "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F) (D@E))" using G'(3) by auto
qed
qed simp
qed
lemma tr⇩p⇩a⇩i⇩r⇩s_trms_subset:
"G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D) ⟹ trms⇩p⇩a⇩i⇩r⇩s G ⊆ pair ` set F ∪ pair ` set D"
proof (induction F D arbitrary: G rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F D G)
obtain d G' where G:
"d ∈ set D" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)" "G = (pair (s,t), pair d)#G'"
using "2.prems"(1) by moura
show ?case using "2.IH"[OF G(1,2)] G(1,3) by auto
qed simp
lemma tr⇩p⇩a⇩i⇩r⇩s_trms_subset':
"⋃(trms⇩p⇩a⇩i⇩r⇩s ` set (tr⇩p⇩a⇩i⇩r⇩s F D)) ⊆ pair ` set F ∪ pair ` set D"
using tr⇩p⇩a⇩i⇩r⇩s_trms_subset by blast
lemma tr_trms_subset:
"A' ∈ set (tr A D) ⟹ trms⇩s⇩t A' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D"
proof (induction A D arbitrary: A' rule: tr.induct)
case 1 thus ?case by simp
next
case (2 t A D)
then obtain A'' where A'': "A' = send⟨t⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)" by moura
hence "trms⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D" by (metis "2.IH")
thus ?case using A'' by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (3 t A D)
then obtain A'' where A'': "A' = receive⟨t⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)" by moura
hence "trms⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D" by (metis "3.IH")
thus ?case using A'' by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (4 ac t t' A D)
then obtain A'' where A'': "A' = ⟨ac: t ≐ t'⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)" by moura
hence "trms⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D" by (metis "4.IH")
thus ?case using A'' by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (5 t s A D)
hence "A' ∈ set (tr A (List.insert (t,s) D))" by simp
hence "trms⇩s⇩t A' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set (List.insert (t, s) D)"
by (metis "5.IH")
thus ?case by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (6 t s A D)
from 6 obtain Di A'' B C where A'':
"Di ∈ set (subseqs D)" "A'' ∈ set (tr A [d←D. d ∉ set Di])" "A' = (B@C)@A''"
"B = map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di"
"C = map (λd. Inequality [] [(pair (t,s) , pair d)]) [d←D. d ∉ set Di]"
by moura
hence "trms⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set [d←D. d ∉ set Di]"
by (metis "6.IH")
hence "trms⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (Delete t s#A) ∪ pair ` setops⇩s⇩s⇩t (Delete t s#A) ∪ pair ` set D"
by (auto simp add: setops⇩s⇩s⇩t_def)
moreover have "trms⇩s⇩t (B@C) ⊆ insert (pair (t,s)) (pair ` set D)"
using A''(4,5) subseqs_set_subset[OF A''(1)] by auto
moreover have "pair (t,s) ∈ pair ` setops⇩s⇩s⇩t (Delete t s#A)" by (simp add: setops⇩s⇩s⇩t_def)
ultimately show ?case using A''(3) trms⇩s⇩t_append[of "B@C" A'] by auto
next
case (7 ac t s A D)
from 7 obtain d A'' where A'':
"d ∈ set D" "A'' ∈ set (tr A D)"
"A' = ⟨ac: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t#A''"
by moura
hence "trms⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D" by (metis "7.IH")
moreover have "trms⇩s⇩t A' = {pair (t,s), pair d} ∪ trms⇩s⇩t A''"
using A''(1,3) by auto
ultimately show ?case using A''(1) by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (8 X F F' A D)
from 8 obtain A'' where A'':
"A'' ∈ set (tr A D)" "A' = (map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D))@A''"
by moura
define B where "B ≡ ⋃(trms⇩p⇩a⇩i⇩r⇩s ` set (tr⇩p⇩a⇩i⇩r⇩s F' D))"
have "trms⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D" by (metis A''(1) "8.IH")
hence "trms⇩s⇩t A' ⊆ B ∪ trms⇩p⇩a⇩i⇩r⇩s F ∪ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D"
using A'' B_def by auto
moreover have "B ⊆ pair ` set F' ∪ pair ` set D"
using tr⇩p⇩a⇩i⇩r⇩s_trms_subset'[of F' D] B_def by simp
moreover have "pair ` setops⇩s⇩s⇩t (∀X⟨∨≠: F ∨∉: F'⟩#A) = pair ` set F' ∪ pair ` setops⇩s⇩s⇩t A"
by (auto simp add: setops⇩s⇩s⇩t_def)
ultimately show ?case by auto
qed
lemma tr⇩p⇩a⇩i⇩r⇩s_vars_subset:
"G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D) ⟹ fv⇩p⇩a⇩i⇩r⇩s G ⊆ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s D"
proof (induction F D arbitrary: G rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F D G)
obtain d G' where G:
"d ∈ set D" "G' ∈ set (tr⇩p⇩a⇩i⇩r⇩s F D)" "G = (pair (s,t), pair d)#G'"
using "2.prems"(1) by moura
show ?case using "2.IH"[OF G(1,2)] G(1,3) unfolding pair_def by auto
qed simp
lemma tr⇩p⇩a⇩i⇩r⇩s_vars_subset': "⋃(fv⇩p⇩a⇩i⇩r⇩s ` set (tr⇩p⇩a⇩i⇩r⇩s F D)) ⊆ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s D"
using tr⇩p⇩a⇩i⇩r⇩s_vars_subset[of _ F D] by blast
lemma tr_vars_subset:
assumes "A' ∈ set (tr A D)"
shows "fv⇩s⇩t A' ⊆ fv⇩s⇩s⇩t A ∪ (⋃(t,t') ∈ set D. fv t ∪ fv t')" (is ?P)
and "bvars⇩s⇩t A' ⊆ bvars⇩s⇩s⇩t A" (is ?Q)
proof -
show ?P using assms
proof (induction A arbitrary: A' D rule: strand_sem_stateful_induct)
case (ConsIn A' D ac t s A)
then obtain A'' d where *:
"d ∈ set D" "A' = ⟨ac: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t#A''"
"A'' ∈ set (tr A D)"
by moura
hence "fv⇩s⇩t A'' ⊆ fv⇩s⇩s⇩t A ∪ (⋃(t,t')∈set D. fv t ∪ fv t')" by (metis ConsIn.IH)
thus ?case using * unfolding pair_def by auto
next
case (ConsDel A' D t s A)
define Dfv where "Dfv ≡ λD::('fun,'var) dbstatelist. (⋃(t,t')∈set D. fv t ∪ fv t')"
define fltD where "fltD ≡ λDi. filter (λd. d ∉ set Di) D"
define constr where
"constr ≡ λDi. (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) (fltD Di))"
from ConsDel obtain A'' Di where *:
"Di ∈ set (subseqs D)" "A' = (constr Di)@A''" "A'' ∈ set (tr A (fltD Di))"
unfolding constr_def fltD_def by moura
hence "fv⇩s⇩t A'' ⊆ fv⇩s⇩s⇩t A ∪ Dfv (fltD Di)"
unfolding Dfv_def constr_def fltD_def by (metis ConsDel.IH)
moreover have "Dfv (fltD Di) ⊆ Dfv D" unfolding Dfv_def constr_def fltD_def by auto
moreover have "Dfv Di ⊆ Dfv D"
using subseqs_set_subset(1)[OF *(1)] unfolding Dfv_def constr_def fltD_def by fast
moreover have "fv⇩s⇩t (constr Di) ⊆ fv t ∪ fv s ∪ (Dfv Di ∪ Dfv (fltD Di))"
unfolding Dfv_def constr_def fltD_def pair_def by auto
moreover have "fv⇩s⇩s⇩t (Delete t s#A) = fv t ∪ fv s ∪ fv⇩s⇩s⇩t A" by auto
moreover have "fv⇩s⇩t A' = fv⇩s⇩t (constr Di) ∪ fv⇩s⇩t A''" using * by force
ultimately have "fv⇩s⇩t A' ⊆ fv⇩s⇩s⇩t (Delete t s#A) ∪ Dfv D" by auto
thus ?case unfolding Dfv_def fltD_def constr_def by simp
next
case (ConsNegChecks A' D X F F' A)
then obtain A'' where A'':
"A'' ∈ set (tr A D)" "A' = (map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D))@A''"
by moura
define B where "B ≡ ⋃(fv⇩p⇩a⇩i⇩r⇩s ` set (tr⇩p⇩a⇩i⇩r⇩s F' D))"
have 1: "fv⇩s⇩t (map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D)) ⊆ (B ∪ fv⇩p⇩a⇩i⇩r⇩s F) - set X"
unfolding B_def by auto
have 2: "B ⊆ fv⇩p⇩a⇩i⇩r⇩s F' ∪ fv⇩p⇩a⇩i⇩r⇩s D"
using tr⇩p⇩a⇩i⇩r⇩s_vars_subset'[of F' D]
unfolding B_def by simp
have "fv⇩s⇩t A' ⊆ ((fv⇩p⇩a⇩i⇩r⇩s F' ∪ fv⇩p⇩a⇩i⇩r⇩s D ∪ fv⇩p⇩a⇩i⇩r⇩s F) - set X) ∪ fv⇩s⇩t A''"
using 1 2 A''(2) by fastforce
thus ?case using ConsNegChecks.IH[OF A''(1)] by auto
qed fastforce+
show ?Q using assms by (induct A arbitrary: A' D rule: strand_sem_stateful_induct) fastforce+
qed
lemma tr_vars_disj:
assumes "A' ∈ set (tr A D)" "∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
and "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}"
shows "fv⇩s⇩t A' ∩ bvars⇩s⇩t A' = {}"
using assms tr_vars_subset by fast
lemma wf_fun_pair_ineqs_map:
assumes "wf⇩s⇩t X A"
shows "wf⇩s⇩t X (map (λd. ∀Y⟨∨≠: [(pair (t, s), pair d)]⟩⇩s⇩t) D@A)"
using assms by (induct D) auto
lemma wf_fun_pair_negchecks_map:
assumes "wf⇩s⇩t X A"
shows "wf⇩s⇩t X (map (λG. ∀Y⟨∨≠: (F@G)⟩⇩s⇩t) M@A)"
using assms by (induct M) auto
lemma wf_fun_pair_eqs_ineqs_map:
fixes A::"('fun,'var) strand"
assumes "wf⇩s⇩t X A" "Di ∈ set (subseqs D)" "∀(t,t') ∈ set D. fv t ∪ fv t' ⊆ X"
shows "wf⇩s⇩t X ((map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di])@A)"
proof -
let ?c1 = "map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di"
let ?c2 = "map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di]"
have 1: "wf⇩s⇩t X (?c2@A)" using wf_fun_pair_ineqs_map[OF assms(1)] by simp
have 2: "∀(t,t') ∈ set Di. fv t ∪ fv t' ⊆ X"
using assms(2,3) by (meson contra_subsetD subseqs_set_subset(1))
have "wf⇩s⇩t X (?c1@B)" when "wf⇩s⇩t X B" for B::"('fun,'var) strand"
using 2 that by (induct Di) auto
thus ?thesis using 1 by simp
qed
lemma trms⇩s⇩s⇩t_wt_subst_ex:
assumes θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and t: "t ∈ trms⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
shows "∃s δ. s ∈ trms⇩s⇩s⇩t S ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = s ⋅ δ"
using t
proof (induction S)
case (Cons s S) thus ?case
proof (cases "t ∈ trms⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)")
case False
hence "t ∈ trms⇩s⇩s⇩t⇩p (s ⋅⇩s⇩s⇩t⇩p θ)"
using Cons.prems trms⇩s⇩s⇩t_subst_cons[of s S θ]
by auto
then obtain u where u: "u ∈ trms⇩s⇩s⇩t⇩p s" "t = u ⋅ rm_vars (set (bvars⇩s⇩s⇩t⇩p s)) θ"
using trms⇩s⇩s⇩t⇩p_subst'' by blast
thus ?thesis
using trms⇩s⇩s⇩t_subst_cons[of s S θ]
wt_subst_rm_vars[OF θ(1), of "set (bvars⇩s⇩s⇩t⇩p s)"]
wf_trms_subst_rm_vars'[OF θ(2), of "set (bvars⇩s⇩s⇩t⇩p s)"]
by fastforce
qed auto
qed simp
lemma setops⇩s⇩s⇩t_wt_subst_ex:
assumes θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
and t: "t ∈ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
shows "∃s δ. s ∈ pair ` setops⇩s⇩s⇩t S ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t = s ⋅ δ"
using t
proof (induction S)
case (Cons x S) thus ?case
proof (cases x)
case (Insert t' s)
hence "t = pair (t',s) ⋅ θ ∨ t ∈ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using Cons.prems subst_sst_cons[of _ S θ]
unfolding pair_def by (force simp add: setops⇩s⇩s⇩t_def)
thus ?thesis
using Insert Cons.IH θ by (cases "t = pair (t', s) ⋅ θ") (fastforce, auto)
next
case (Delete t' s)
hence "t = pair (t',s) ⋅ θ ∨ t ∈ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using Cons.prems subst_sst_cons[of _ S θ]
unfolding pair_def by (force simp add: setops⇩s⇩s⇩t_def)
thus ?thesis
using Delete Cons.IH θ by (cases "t = pair (t', s) ⋅ θ") (fastforce, auto)
next
case (InSet ac t' s)
hence "t = pair (t',s) ⋅ θ ∨ t ∈ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using Cons.prems subst_sst_cons[of _ S θ]
unfolding pair_def by (force simp add: setops⇩s⇩s⇩t_def)
thus ?thesis
using InSet Cons.IH θ by (cases "t = pair (t', s) ⋅ θ") (fastforce, auto)
next
case (NegChecks X F F')
hence "t ∈ pair ` set (F' ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ) ∨ t ∈ pair ` setops⇩s⇩s⇩t (S ⋅⇩s⇩s⇩t θ)"
using Cons.prems subst_sst_cons[of _ S θ]
unfolding pair_def by (force simp add: setops⇩s⇩s⇩t_def)
thus ?thesis
proof
assume "t ∈ pair ` set (F' ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) θ)"
then obtain s where s: "t = s ⋅ rm_vars (set X) θ" "s ∈ pair ` set F'"
using subst_apply_pairs_pair_image_subst[of F' "rm_vars (set X) θ"] by auto
thus ?thesis
using NegChecks setops⇩s⇩s⇩t_pair_image_cons(8)[of X F F' S]
wt_subst_rm_vars[OF θ(1), of "set X"]
wf_trms_subst_rm_vars'[OF θ(2), of "set X"]
by fast
qed (use Cons.IH in auto)
qed (auto simp add: setops⇩s⇩s⇩t_def subst_sst_cons[of _ S θ])
qed (simp add: setops⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t_wf⇩t⇩r⇩m⇩s:
"wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A) ⟹ wf⇩t⇩r⇩m⇩s (pair ` setops⇩s⇩s⇩t A)"
"wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A) ⟹ wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A)"
proof -
show "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A) ⟹ wf⇩t⇩r⇩m⇩s (pair ` setops⇩s⇩s⇩t A)"
proof (induction A)
case (Cons a A)
hence 0: "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t⇩p a)" "wf⇩t⇩r⇩m⇩s (pair ` setops⇩s⇩s⇩t A)" by auto
thus ?case
proof (cases a)
case (NegChecks X F F')
hence "wf⇩t⇩r⇩m⇩s (trms⇩p⇩a⇩i⇩r⇩s F')" using 0 by simp
thus ?thesis using NegChecks wf⇩t⇩r⇩m⇩s_pairs[of F'] 0 by (auto simp add: setops⇩s⇩s⇩t_def)
qed (auto simp add: setops⇩s⇩s⇩t_def dest: fun_pair_wf⇩t⇩r⇩m)
qed (auto simp add: setops⇩s⇩s⇩t_def)
thus "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A) ⟹ wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A)" by fast
qed
lemma SMP_MP_split:
assumes "t ∈ SMP M"
and M: "∀m ∈ M. is_Fun m"
shows "(∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t ∈ M ⋅⇩s⇩e⇩t δ) ∨
t ∈ SMP ((subterms⇩s⇩e⇩t M ∪ ⋃((set ∘ fst ∘ Ana) ` M)) - M)"
(is "?P t ∨ ?Q t")
using assms(1)
proof (induction t rule: SMP.induct)
case (MP t)
have "wt⇩s⇩u⇩b⇩s⇩t Var" "wf⇩t⇩r⇩m⇩s (subst_range Var)" "M ⋅⇩s⇩e⇩t Var = M" by simp_all
thus ?case using MP by metis
next
case (Subterm t t')
show ?case using Subterm.IH
proof
assume "?P t"
then obtain s δ where s: "s ∈ M" "t = s ⋅ δ" and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" by moura
then obtain f T where fT: "s = Fun f T" using M by fast
have "(∃s'. s' ⊑ s ∧ t' = s' ⋅ δ) ∨ (∃x ∈ fv s. t' ⊏ δ x)"
using subterm_subst_unfold[OF Subterm.hyps(2)[unfolded s(2)]] by blast
thus ?thesis
proof
assume "∃s'. s' ⊑ s ∧ t' = s' ⋅ δ"
then obtain s' where s': "s' ⊑ s" "t' = s' ⋅ δ" by moura
show ?thesis
proof (cases "s' ∈ M")
case True thus ?thesis using s' δ by blast
next
case False
hence "s' ∈ (subterms⇩s⇩e⇩t M ∪ ⋃((set ∘ fst ∘ Ana) ` M)) - M" using s'(1) s(1) by force
thus ?thesis using SMP.Substitution[OF SMP.MP[of s'] δ] s' by presburger
qed
next
assume "∃x ∈ fv s. t' ⊏ δ x"
then obtain x where x: "x ∈ fv s" "t' ⊏ δ x" by moura
have "Var x ∉ M" using M by blast
hence "Var x ∈ (subterms⇩s⇩e⇩t M ∪ ⋃((set ∘ fst ∘ Ana) ` M)) - M"
using s(1) var_is_subterm[OF x(1)] by blast
hence "δ x ∈ SMP ((subterms⇩s⇩e⇩t M ∪ ⋃((set ∘ fst ∘ Ana) ` M)) - M)"
using SMP.Substitution[OF SMP.MP[of "Var x"] δ] by auto
thus ?thesis using SMP.Subterm x(2) by presburger
qed
qed (metis SMP.Subterm[OF _ Subterm.hyps(2)])
next
case (Substitution t δ)
show ?case using Substitution.IH
proof
assume "?P t"
then obtain θ where "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "t ∈ M ⋅⇩s⇩e⇩t θ" by moura
hence "wt⇩s⇩u⇩b⇩s⇩t (θ ∘⇩s δ)" "wf⇩t⇩r⇩m⇩s (subst_range (θ ∘⇩s δ))" "t ⋅ δ ∈ M ⋅⇩s⇩e⇩t (θ ∘⇩s δ)"
using wt_subst_compose[of θ, OF _ Substitution.hyps(2)]
wf_trm_subst_compose[of θ _ δ, OF _ wf_trm_subst_rangeD[OF Substitution.hyps(3)]]
wf_trm_subst_range_iff
by (argo, blast, auto)
thus ?thesis by blast
next
assume "?Q t" thus ?thesis using SMP.Substitution[OF _ Substitution.hyps(2,3)] by meson
qed
next
case (Ana t K T k)
show ?case using Ana.IH
proof
assume "?P t"
then obtain θ where θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)" "t ∈ M ⋅⇩s⇩e⇩t θ" by moura
then obtain s where s: "s ∈ M" "t = s ⋅ θ" by auto
then obtain f S where fT: "s = Fun f S" using M by (cases s) auto
obtain K' T' where s_Ana: "Ana s = (K', T')" by (metis surj_pair)
hence "set K = set K' ⋅⇩s⇩e⇩t θ" "set T = set T' ⋅⇩s⇩e⇩t θ"
using Ana_subst'[of f S K' T'] fT Ana.hyps(2) s(2) by auto
then obtain k' where k': "k' ∈ set K'" "k = k' ⋅ θ" using Ana.hyps(3) by fast
show ?thesis
proof (cases "k' ∈ M")
case True thus ?thesis using k' θ(1,2) by blast
next
case False
hence "k' ∈ (subterms⇩s⇩e⇩t M ∪ ⋃((set ∘ fst ∘ Ana) ` M)) - M" using k'(1) s_Ana s(1) by force
thus ?thesis using SMP.Substitution[OF SMP.MP[of k'] θ(1,2)] k'(2) by presburger
qed
next
assume "?Q t" thus ?thesis using SMP.Ana[OF _ Ana.hyps(2,3)] by meson
qed
qed
lemma setops_subterm_trms:
assumes t: "t ∈ pair ` setops⇩s⇩s⇩t S"
and s: "s ⊏ t"
shows "s ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t S)"
proof -
obtain u u' where u: "pair (u,u') ∈ pair ` setops⇩s⇩s⇩t S" "t = pair (u,u')"
using t setops⇩s⇩s⇩t_are_pairs[of _ S] by blast
hence "s ⊑ u ∨ s ⊑ u'" using s unfolding pair_def by auto
thus ?thesis using u setops⇩s⇩s⇩t_member_iff[of u u' S] unfolding trms⇩s⇩s⇩t_def by force
qed
lemma setops_subterms_cases:
assumes t: "t ∈ subterms⇩s⇩e⇩t (pair ` setops⇩s⇩s⇩t S)"
shows "t ∈ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t S) ∨ t ∈ pair ` setops⇩s⇩s⇩t S"
proof -
obtain s s' where s: "pair (s,s') ∈ pair ` setops⇩s⇩s⇩t S" "t ⊑ pair (s,s')"
using t setops⇩s⇩s⇩t_are_pairs[of _ S] by blast
hence "t ∈ pair ` setops⇩s⇩s⇩t S ∨ t ⊑ s ∨ t ⊑ s'" unfolding pair_def by auto
thus ?thesis using s setops⇩s⇩s⇩t_member_iff[of s s' S] unfolding trms⇩s⇩s⇩t_def by force
qed
lemma setops_SMP_cases:
assumes "t ∈ SMP (pair ` setops⇩s⇩s⇩t S)"
and "∀p. Ana (pair p) = ([], [])"
shows "(∃δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ t ∈ pair ` setops⇩s⇩s⇩t S ⋅⇩s⇩e⇩t δ) ∨ t ∈ SMP (trms⇩s⇩s⇩t S)"
proof -
have 0: "⋃((set ∘ fst ∘ Ana) ` pair ` setops⇩s⇩s⇩t S) = {}"
proof (induction S)
case (Cons x S) thus ?case
using assms(2) by (cases x) (auto simp add: setops⇩s⇩s⇩t_def)
qed (simp add: setops⇩s⇩s⇩t_def)
have 1: "∀m ∈ pair ` setops⇩s⇩s⇩t S. is_Fun m"
proof (induction S)
case (Cons x S) thus ?case
unfolding pair_def by (cases x) (auto simp add: assms(2) setops⇩s⇩s⇩t_def)
qed (simp add: setops⇩s⇩s⇩t_def)
have 2:
"subterms⇩s⇩e⇩t (pair ` setops⇩s⇩s⇩t S) ∪
⋃((set ∘ fst ∘ Ana) ` (pair ` setops⇩s⇩s⇩t S)) - pair ` setops⇩s⇩s⇩t S
⊆ subterms⇩s⇩e⇩t (trms⇩s⇩s⇩t S)"
using 0 setops_subterms_cases by fast
show ?thesis
using SMP_MP_split[OF assms(1) 1] SMP_mono[OF 2] SMP_subterms_eq[of "trms⇩s⇩s⇩t S"]
by blast
qed
lemma tfr_setops_if_tfr_trms:
assumes "Pair ∉ ⋃(funs_term ` SMP (trms⇩s⇩s⇩t S))"
and "∀p. Ana (pair p) = ([], [])"
and "∀s ∈ pair ` setops⇩s⇩s⇩t S. ∀t ∈ pair ` setops⇩s⇩s⇩t S. (∃δ. Unifier δ s t) ⟶ Γ s = Γ t"
and "∀s ∈ pair ` setops⇩s⇩s⇩t S. ∀t ∈ pair ` setops⇩s⇩s⇩t S.
(∃σ θ ρ. wt⇩s⇩u⇩b⇩s⇩t σ ∧ wt⇩s⇩u⇩b⇩s⇩t θ ∧ wf⇩t⇩r⇩m⇩s (subst_range σ) ∧ wf⇩t⇩r⇩m⇩s (subst_range θ) ∧
Unifier ρ (s ⋅ σ) (t ⋅ θ))
⟶ (∃δ. Unifier δ s t)"
and tfr: "tfr⇩s⇩e⇩t (trms⇩s⇩s⇩t S)"
shows "tfr⇩s⇩e⇩t (trms⇩s⇩s⇩t S ∪ pair ` setops⇩s⇩s⇩t S)"
proof -
have 0: "t ∈ SMP (trms⇩s⇩s⇩t S) - range Var ∨ t ∈ SMP (pair ` setops⇩s⇩s⇩t S) - range Var"
when "t ∈ SMP (trms⇩s⇩s⇩t S ∪ pair ` setops⇩s⇩s⇩t S) - range Var" for t
using that SMP_union by blast
have 1: "s ∈ SMP (trms⇩s⇩s⇩t S) - range Var"
when st: "s ∈ SMP (pair ` setops⇩s⇩s⇩t S) - range Var"
"t ∈ SMP (trms⇩s⇩s⇩t S) - range Var"
"∃δ. Unifier δ s t"
for s t
proof -
have "(∃δ. s ∈ pair ` setops⇩s⇩s⇩t S ⋅⇩s⇩e⇩t δ) ∨ s ∈ SMP (trms⇩s⇩s⇩t S) - range Var"
using st setops_SMP_cases[of s S] assms(2) by blast
moreover {
fix δ assume δ: "s ∈ pair ` setops⇩s⇩s⇩t S ⋅⇩s⇩e⇩t δ"
then obtain s' where s': "s' ∈ pair ` setops⇩s⇩s⇩t S" "s = s' ⋅ δ" by blast
then obtain u u' where u: "s' = Fun Pair [u,u']"
using setops⇩s⇩s⇩t_are_pairs[of s'] unfolding pair_def by fast
hence *: "s = Fun Pair [u ⋅ δ, u' ⋅ δ]" using δ s' by simp
obtain f T where fT: "t = Fun f T" using st(2) by (cases t) auto
hence "f ≠ Pair" using st(2) assms(1) by auto
hence False using st(3) * fT s' u by fast
} ultimately show ?thesis by meson
qed
have 2: "Γ s = Γ t"
when "s ∈ SMP (trms⇩s⇩s⇩t S) - range Var"
"t ∈ SMP (trms⇩s⇩s⇩t S) - range Var"
"∃δ. Unifier δ s t"
for s t
using that tfr unfolding tfr⇩s⇩e⇩t_def by blast
have 3: "Γ s = Γ t"
when st: "s ∈ SMP (pair ` setops⇩s⇩s⇩t S) - range Var"
"t ∈ SMP (pair ` setops⇩s⇩s⇩t S) - range Var"
"∃δ. Unifier δ s t"
for s t
proof -
let ?P = "λs δ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ s ∈ pair ` setops⇩s⇩s⇩t S ⋅⇩s⇩e⇩t δ"
have "(∃δ. ?P s δ) ∨ s ∈ SMP (trms⇩s⇩s⇩t S) - range Var"
"(∃δ. ?P t δ) ∨ t ∈ SMP (trms⇩s⇩s⇩t S) - range Var"
using setops_SMP_cases[of _ S] assms(2) st(1,2) by auto
hence "(∃δ δ'. ?P s δ ∧ ?P t δ') ∨ Γ s = Γ t" by (metis 1 2 st)
moreover {
fix δ δ' assume *: "?P s δ" "?P t δ'"
then obtain s' t' where **:
"s' ∈ pair ` setops⇩s⇩s⇩t S" "t' ∈ pair ` setops⇩s⇩s⇩t S" "s = s' ⋅ δ" "t = t' ⋅ δ'"
by blast
hence "∃θ. Unifier θ s' t'" using st(3) assms(4) * by blast
hence "Γ s' = Γ t'" using assms(3) ** by blast
hence "Γ s = Γ t" using * **(3,4) wt_subst_trm''[of δ s'] wt_subst_trm''[of δ' t'] by argo
} ultimately show ?thesis by blast
qed
show ?thesis using 0 1 2 3 unfolding tfr⇩s⇩e⇩t_def by metis
qed
subsection ‹The Typing Result for Stateful Constraints›
context
begin
private lemma tr_wf':
assumes "∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
and "∀(t,t') ∈ set D. fv t ∪ fv t' ⊆ X"
and "wf'⇩s⇩s⇩t X A" "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}"
and "A' ∈ set (tr A D)"
shows "wf⇩s⇩t X A'"
proof -
define P where
"P = (λ(D::('fun,'var) dbstatelist) (A::('fun,'var) stateful_strand).
(∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}) ∧ fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {})"
have "P D A" using assms(1,4) by (simp add: P_def)
with assms(5,3,2) show ?thesis
proof (induction A arbitrary: A' D X rule: wf'⇩s⇩s⇩t.induct)
case 1 thus ?case by simp
next
case (2 X t A A')
then obtain A'' where A'': "A' = receive⟨t⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)" "fv t ⊆ X"
by moura
have *: "wf'⇩s⇩s⇩t X A" "∀(s,s') ∈ set D. fv s ∪ fv s' ⊆ X" "P D A"
using 2(1,2,3,4) apply (force, force)
using 2(5) unfolding P_def by force
show ?case using "2.IH"[OF A''(2) *] A''(1,3) by simp
next
case (3 X t A A')
then obtain A'' where A'': "A' = send⟨t⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)"
by moura
have *: "wf'⇩s⇩s⇩t (X ∪ fv t) A" "∀(s,s') ∈ set D. fv s ∪ fv s' ⊆ X ∪ fv t" "P D A"
using 3(1,2,3,4) apply (force, force)
using 3(5) unfolding P_def by force
show ?case using "3.IH"[OF A''(2) *] A''(1) by simp
next
case (4 X t t' A A')
then obtain A'' where A'': "A' = ⟨assign: t ≐ t'⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)" "fv t' ⊆ X"
by moura
have *: "wf'⇩s⇩s⇩t (X ∪ fv t) A" "∀(s,s') ∈ set D. fv s ∪ fv s' ⊆ X ∪ fv t" "P D A"
using 4(1,2,3,4) apply (force, force)
using 4(5) unfolding P_def by force
show ?case using "4.IH"[OF A''(2) *] A''(1,3) by simp
next
case (5 X t t' A A')
then obtain A'' where A'': "A' = ⟨check: t ≐ t'⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)"
by moura
have *: "wf'⇩s⇩s⇩t X A" "P D A"
using 5(3) apply force
using 5(5) unfolding P_def by force
show ?case using "5.IH"[OF A''(2) *(1) 5(4) *(2)] A''(1) by simp
next
case (6 X t s A A')
hence A': "A' ∈ set (tr A (List.insert (t,s) D))" "fv t ⊆ X" "fv s ⊆ X" by auto
have *: "wf'⇩s⇩s⇩t X A" "∀(s,s') ∈ set (List.insert (t,s) D). fv s ∪ fv s' ⊆ X" using 6 by auto
have **: "P (List.insert (t,s) D) A" using 6(5) unfolding P_def by force
show ?case using "6.IH"[OF A'(1) * **] A'(2,3) by simp
next
case (7 X t s A A')
let ?constr = "λDi. (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di])"
from 7 obtain Di A'' where A'':
"A' = ?constr Di@A''" "A'' ∈ set (tr A [d←D. d ∉ set Di])"
"Di ∈ set (subseqs D)"
by moura
have *: "wf'⇩s⇩s⇩t X A" "∀(t',s') ∈ set [d←D. d ∉ set Di]. fv t' ∪ fv s' ⊆ X"
using 7 by auto
have **: "P [d←D. d ∉ set Di] A" using 7 unfolding P_def by force
have ***: "∀(t, t') ∈ set D. fv t ∪ fv t' ⊆ X" using 7 by auto
show ?case
using "7.IH"[OF A''(2) * **] A''(1) wf_fun_pair_eqs_ineqs_map[OF _ A''(3) ***]
by simp
next
case (8 X t s A A')
then obtain d A'' where A'':
"A' = ⟨assign: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t#A''"
"A'' ∈ set (tr A D)" "d ∈ set D"
by moura
have *: "wf'⇩s⇩s⇩t (X ∪ fv t ∪ fv s) A" "∀(t',s')∈set D. fv t' ∪ fv s' ⊆ X ∪ fv t ∪ fv s" "P D A"
using 8(1,2,3,4) apply (force, force)
using 8(5) unfolding P_def by force
have **: "fv (pair d) ⊆ X" using A''(3) "8.prems"(3) unfolding pair_def by fastforce
have ***: "fv (pair (t,s)) = fv s ∪ fv t" unfolding pair_def by auto
show ?case using "8.IH"[OF A''(2) *] A''(1) ** *** unfolding pair_def by (simp add: Un_assoc)
next
case (9 X t s A A')
then obtain d A'' where A'':
"A' = ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t#A''"
"A'' ∈ set (tr A D)" "d ∈ set D"
by moura
have *: "wf'⇩s⇩s⇩t X A""P D A"
using 9(3) apply force
using 9(5) unfolding P_def by force
have **: "fv (pair d) ⊆ X" using A''(3) "9.prems"(3) unfolding pair_def by fastforce
have ***: "fv (pair (t,s)) = fv s ∪ fv t" unfolding pair_def by auto
show ?case using "9.IH"[OF A''(2) *(1) 9(4) *(2)] A''(1) ** *** by (simp add: Un_assoc)
next
case (10 X Y F F' A A')
from 10 obtain A'' where A'':
"A' = (map (λG. ∀Y⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D))@A''" "A'' ∈ set (tr A D)"
by moura
have *: "wf'⇩s⇩s⇩t X A" "∀(t',s') ∈ set D. fv t' ∪ fv s' ⊆ X" using 10 by auto
have "bvars⇩s⇩s⇩t A ⊆ bvars⇩s⇩s⇩t (∀Y⟨∨≠: F ∨∉: F'⟩#A)" "fv⇩s⇩s⇩t A ⊆ fv⇩s⇩s⇩t (∀Y⟨∨≠: F ∨∉: F'⟩#A)" by auto
hence **: "P D A" using 10 unfolding P_def by blast
show ?case using "10.IH"[OF A''(2) * **] A''(1) wf_fun_pair_negchecks_map by simp
qed
qed
private lemma tr_wf⇩t⇩r⇩m⇩s:
assumes "A' ∈ set (tr A [])" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A)"
shows "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t A')"
using tr_trms_subset[OF assms(1)] setops⇩s⇩s⇩t_wf⇩t⇩r⇩m⇩s(2)[OF assms(2)]
by auto
lemma tr_wf:
assumes "A' ∈ set (tr A [])"
and "wf⇩s⇩s⇩t A"
and "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t A)"
shows "wf⇩s⇩t {} A'"
and "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t A')"
and "fv⇩s⇩t A' ∩ bvars⇩s⇩t A' = {}"
using tr_wf'[OF _ _ _ _ assms(1)]
tr_wf⇩t⇩r⇩m⇩s[OF assms(1,3)]
tr_vars_disj[OF assms(1)]
assms(2)
by fastforce+
private lemma tr_tfr⇩s⇩s⇩t⇩p:
assumes "A' ∈ set (tr A D)" "list_all tfr⇩s⇩s⇩t⇩p A"
and "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" (is "?P0 A D")
and "∀(t,s) ∈ set D. (fv t ∪ fv s) ∩ bvars⇩s⇩s⇩t A = {}" (is "?P1 A D")
and "∀t ∈ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D. ∀t' ∈ pair ` setops⇩s⇩s⇩t A ∪ pair ` set D.
(∃δ. Unifier δ t t') ⟶ Γ t = Γ t'" (is "?P3 A D")
shows "list_all tfr⇩s⇩t⇩p A'"
proof -
have sublmm: "list_all tfr⇩s⇩s⇩t⇩p A" "?P0 A D" "?P1 A D" "?P3 A D"
when p: "list_all tfr⇩s⇩s⇩t⇩p (a#A)" "?P0 (a#A) D" "?P1 (a#A) D" "?P3 (a#A) D"
for a A D
using p(1) apply (simp add: tfr⇩s⇩s⇩t_def)
using p(2) fv⇩s⇩s⇩t_cons_subset bvars⇩s⇩s⇩t_cons_subset apply fast
using p(3) bvars⇩s⇩s⇩t_cons_subset apply fast
using p(4) setops⇩s⇩s⇩t_cons_subset by fast
show ?thesis using assms
proof (induction A D arbitrary: A' rule: tr.induct)
case 1 thus ?case by simp
next
case (2 t A D)
note prems = "2.prems"
note IH = "2.IH"
from prems(1) obtain A'' where A'': "A' = send⟨t⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)"
by moura
have "list_all tfr⇩s⇩t⇩p A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson
thus ?case using A''(1) by simp
next
case (3 t A D)
note prems = "3.prems"
note IH = "3.IH"
from prems(1) obtain A'' where A'': "A' = receive⟨t⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)"
by moura
have "list_all tfr⇩s⇩t⇩p A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson
thus ?case using A''(1) by simp
next
case (4 ac t t' A D)
note prems = "4.prems"
note IH = "4.IH"
from prems(1) obtain A'' where A'':
"A' = ⟨ac: t ≐ t'⟩⇩s⇩t#A''" "A'' ∈ set (tr A D)"
by moura
have "list_all tfr⇩s⇩t⇩p A''" using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)] by meson
moreover have "(∃δ. Unifier δ t t') ⟹ Γ t = Γ t'" using prems(2) by (simp add: tfr⇩s⇩s⇩t_def)
ultimately show ?case using A''(1) by auto
next
case (5 t s A D)
note prems = "5.prems"
note IH = "5.IH"
from prems(1) have A': "A' ∈ set (tr A (List.insert (t,s) D))" by simp
have 1: "list_all tfr⇩s⇩s⇩t⇩p A" using sublmm[OF prems(2,3,4,5)] by simp
have "pair ` setops⇩s⇩s⇩t (Insert t s#A) ∪ pair`set D =
pair ` setops⇩s⇩s⇩t A ∪ pair`set (List.insert (t,s) D)"
by (simp add: setops⇩s⇩s⇩t_def)
hence 3: "?P3 A (List.insert (t,s) D)" using prems(5) by metis
moreover have "?P1 A (List.insert (t, s) D)" using prems(3,4) bvars⇩s⇩s⇩t_cons_subset[of A] by auto
ultimately have "list_all tfr⇩s⇩t⇩p A'" using IH[OF A' sublmm(1,2)[OF prems(2,3,4,5)] _ 3] by metis
thus ?case using A'(1) by auto
next
case (6 t s A D)
note prems = "6.prems"
note IH = "6.IH"
define constr where constr:
"constr ≡ (λDi. (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di]))"
from prems(1) obtain Di A'' where A'':
"A' = constr Di@A''" "A'' ∈ set (tr A [d←D. d ∉ set Di])"
"Di ∈ set (subseqs D)"
unfolding constr by auto
define Q1 where "Q1 ≡ (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀x ∈ (fv⇩p⇩a⇩i⇩r⇩s F) - set X. ∃a. Γ (Var x) = TAtom a)"
define Q2 where "Q2 ≡ (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))"
have "set [d←D. d ∉ set Di] ⊆ set D"
"pair ` setops⇩s⇩s⇩t A ∪ pair ` set [d←D. d ∉ set Di]
⊆ pair ` setops⇩s⇩s⇩t (Delete t s#A) ∪ pair ` set D"
by (auto simp add: setops⇩s⇩s⇩t_def)
hence *: "?P3 A [d←D. d ∉ set Di]" using prems(5) by blast
have **: "?P1 A [d←D. d ∉ set Di]" using prems(4,5) by auto
have 1: "list_all tfr⇩s⇩t⇩p A''"
using IH[OF A''(3,2) sublmm(1,2)[OF prems(2,3,4,5)] ** *]
by metis
have 2: "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set A'' ∨
(∃d ∈ set Di. u = pair (t,s) ∧ u' = pair d)"
when "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set A'" for ac u u'
using that A''(1) unfolding constr by force
have 3: "Inequality X U ∈ set A' ⟹ Inequality X U ∈ set A'' ∨
(∃d ∈ set [d←D. d ∉ set Di].
U = [(pair (t,s), pair d)] ∧ Q2 [(pair (t,s), pair d)] X)"
for X U
using A''(1) unfolding Q2_def constr by force
have 4:
"∀d∈set D. (∃δ. Unifier δ (pair (t,s)) (pair d)) ⟶ Γ (pair (t,s)) = Γ (pair d)"
using prems(5) by (simp add: setops⇩s⇩s⇩t_def)
{ fix ac u u'
assume a: "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set A'" "∃δ. Unifier δ u u'"
hence "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set A'' ∨ (∃d ∈ set Di. u = pair (t,s) ∧ u' = pair d)"
using 2 by metis
hence "Γ u = Γ u'"
using 1(1) 4 subseqs_set_subset[OF A''(3)] a(2) tfr⇩s⇩t⇩p_list_all_alt_def[of A'']
by blast
} moreover {
fix u U
assume "∀U⟨∨≠: u⟩⇩s⇩t ∈ set A'"
hence "∀U⟨∨≠: u⟩⇩s⇩t ∈ set A'' ∨
(∃d ∈ set [d←D. d ∉ set Di]. u = [(pair (t,s), pair d)] ∧ Q2 u U)"
using 3 by metis
hence "Q1 u U ∨ Q2 u U"
using 1 4 subseqs_set_subset[OF A''(3)] tfr⇩s⇩t⇩p_list_all_alt_def[of A'']
unfolding Q1_def Q2_def
by blast
} ultimately show ?case using tfr⇩s⇩t⇩p_list_all_alt_def[of A'] unfolding Q1_def Q2_def by blast
next
case (7 ac t s A D)
note prems = "7.prems"
note IH = "7.IH"
from prems(1) obtain d A'' where A'':
"A' = ⟨ac: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t#A''"
"A'' ∈ set (tr A D)" "d ∈ set D"
by moura
have "list_all tfr⇩s⇩t⇩p A''"
using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
by metis
moreover have "(∃δ. Unifier δ (pair (t,s)) (pair d)) ⟹ Γ (pair (t,s)) = Γ (pair d)"
using prems(2,5) A''(3) unfolding tfr⇩s⇩s⇩t_def by (simp add: setops⇩s⇩s⇩t_def)
ultimately show ?case using A''(1) by fastforce
next
case (8 X F F' A D)
note prems = "8.prems"
note IH = "8.IH"
define constr where "constr = (map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D))"
define Q1 where "Q1 ≡ (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀x ∈ (fv⇩p⇩a⇩i⇩r⇩s F) - set X. ∃a. Γ (Var x) = TAtom a)"
define Q2 where "Q2 ≡ (λ(M::('fun,'var) terms) X.
∀f T. Fun f T ∈ subterms⇩s⇩e⇩t M ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))"
have Q2_subset: "Q2 M' X" when "M' ⊆ M" "Q2 M X" for X M M'
using that unfolding Q2_def by auto
have Q2_supset: "Q2 (M ∪ M') X" when "Q2 M X" "Q2 M' X" for X M M'
using that unfolding Q2_def by auto
from prems(1) obtain A'' where A'': "A' = constr@A''" "A'' ∈ set (tr A D)"
using constr_def by moura
have 0: "F' = [] ⟹ constr = [∀X⟨∨≠: F⟩⇩s⇩t]" unfolding constr_def by simp
have 1: "list_all tfr⇩s⇩t⇩p A''"
using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
by metis
have 2: "(F' = [] ∧ Q1 F X) ∨ Q2 (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') X"
using prems(2) unfolding Q1_def Q2_def by simp
have 3: "list_all tfr⇩s⇩t⇩p constr" when "F' = []" "Q1 F X"
using that 0 2 tfr⇩s⇩t⇩p_list_all_alt_def[of constr] unfolding Q1_def by auto
{ fix c assume "c ∈ set constr"
hence "∃G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D). c = ∀X⟨∨≠: (F@G)⟩⇩s⇩t" unfolding constr_def by force
} moreover {
fix G
assume G: "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D)"
and c: "∀X⟨∨≠: (F@G)⟩⇩s⇩t ∈ set constr"
and e: "Q2 (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') X"
have d_Q2: "Q2 (pair ` set D) X" unfolding Q2_def
proof (intro allI impI)
fix f T assume "Fun f T ∈ subterms⇩s⇩e⇩t (pair ` set D)"
then obtain d where d: "d ∈ set D" "Fun f T ∈ subterms (pair d)" by auto
hence "fv (pair d) ∩ set X = {}" using prems(4) unfolding pair_def by force
thus "T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X)"
by (metis fv_disj_Fun_subterm_param_cases d(2))
qed
have "trms⇩p⇩a⇩i⇩r⇩s (F@G) ⊆ trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F' ∪ pair ` set D"
using tr⇩p⇩a⇩i⇩r⇩s_trms_subset[OF G] by auto
hence "Q2 (trms⇩p⇩a⇩i⇩r⇩s (F@G)) X" using Q2_subset[OF _ Q2_supset[OF e d_Q2]] by metis
hence "tfr⇩s⇩t⇩p (∀X⟨∨≠: (F@G)⟩⇩s⇩t)" by (metis Q2_def tfr⇩s⇩t⇩p.simps(2))
} ultimately have 4: "list_all tfr⇩s⇩t⇩p constr" when "Q2 (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') X"
using that Ball_set by blast
have 5: "list_all tfr⇩s⇩t⇩p constr" using 2 3 4 by metis
show ?case using 1 5 A''(1) by simp
qed
qed
lemma tr_tfr:
assumes "A' ∈ set (tr A [])" and "tfr⇩s⇩s⇩t A" and "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}"
shows "tfr⇩s⇩t A'"
proof -
have *: "trms⇩s⇩t A' ⊆ trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A" using tr_trms_subset[OF assms(1)] by simp
hence "SMP (trms⇩s⇩t A') ⊆ SMP (trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A)" using SMP_mono by simp
moreover have "tfr⇩s⇩e⇩t (trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A)" using assms(2) unfolding tfr⇩s⇩s⇩t_def by fast
ultimately have 1: "tfr⇩s⇩e⇩t (trms⇩s⇩t A')" by (metis tfr_subset(2)[OF _ *])
have **: "list_all tfr⇩s⇩s⇩t⇩p A" using assms(2) unfolding tfr⇩s⇩s⇩t_def by fast
have "pair ` setops⇩s⇩s⇩t A ⊆ SMP (trms⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t A) - Var`𝒱"
using setops⇩s⇩s⇩t_are_pairs unfolding pair_def by auto
hence ***: "∀t ∈ pair`setops⇩s⇩s⇩t A. ∀t' ∈ pair`setops⇩s⇩s⇩t A. (∃δ. Unifier δ t t') ⟶ Γ t = Γ t'"
using assms(2) unfolding tfr⇩s⇩s⇩t_def tfr⇩s⇩e⇩t_def by blast
have 2: "list_all tfr⇩s⇩t⇩p A'"
using tr_tfr⇩s⇩s⇩t⇩p[OF assms(1) ** assms(3)] *** unfolding pair_def by fastforce
show ?thesis by (metis 1 2 tfr⇩s⇩t_def)
qed
private lemma fun_pair_ineqs:
assumes "d ⋅⇩p δ ⋅⇩p θ ≠ d' ⋅⇩p ℐ"
shows "pair d ⋅ δ ⋅ θ ≠ pair d' ⋅ ℐ"
proof -
have "d ⋅⇩p (δ ∘⇩s θ) ≠ d' ⋅⇩p ℐ" using assms subst_pair_compose by metis
hence "pair d ⋅ (δ ∘⇩s θ) ≠ pair d' ⋅ ℐ" using fun_pair_eq_subst by metis
thus ?thesis by simp
qed
private lemma tr_Delete_constr_iff_aux1:
assumes "∀d ∈ set Di. (t,s) ⋅⇩p ℐ = d ⋅⇩p ℐ"
and "∀d ∈ set D - set Di. (t,s) ⋅⇩p ℐ ≠ d ⋅⇩p ℐ"
shows "⟦M; (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di])⟧⇩d ℐ"
proof -
from assms(2) have
"⟦M; map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di]⟧⇩d ℐ"
proof (induction D)
case (Cons d D)
hence IH: "⟦M; map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D . d ∉ set Di]⟧⇩d ℐ" by auto
thus ?case
proof (cases "d ∈ set Di")
case False
hence "(t,s) ⋅⇩p ℐ ≠ d ⋅⇩p ℐ" using Cons by simp
hence "pair (t,s) ⋅ ℐ ≠ pair d ⋅ ℐ" using fun_pair_eq_subst by metis
moreover have "⋀t (δ::('fun,'var) subst). subst_domain δ = {} ⟹ t ⋅ δ = t" by auto
ultimately have "∀δ. subst_domain δ = {} ⟶ pair (t,s) ⋅ δ ⋅ ℐ ≠ pair d ⋅ δ ⋅ ℐ" by metis
thus ?thesis using IH by (simp add: ineq_model_def)
qed simp
qed simp
moreover {
fix B assume "⟦M; B⟧⇩d ℐ"
with assms(1) have "⟦M; (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@B⟧⇩d ℐ"
unfolding pair_def by (induction Di) auto
} ultimately show ?thesis by metis
qed
private lemma tr_Delete_constr_iff_aux2:
assumes "ground M"
and "⟦M; (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di])⟧⇩d ℐ"
shows "(∀d ∈ set Di. (t,s) ⋅⇩p ℐ = d ⋅⇩p ℐ) ∧ (∀d ∈ set D - set Di. (t,s) ⋅⇩p ℐ ≠ d ⋅⇩p ℐ)"
proof -
let ?c1 = "map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di"
let ?c2 = "map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di]"
have "M ⋅⇩s⇩e⇩t ℐ = M" using assms(1) subst_all_ground_ident by metis
moreover have "ik⇩s⇩t ?c1 = {}" by auto
ultimately have *:
"⟦M; map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di⟧⇩d ℐ"
"⟦M; map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di]⟧⇩d ℐ"
using strand_sem_split(3,4)[of M ?c1 ?c2 ℐ] assms(2) by auto
from *(1) have 1: "∀d ∈ set Di. (t,s) ⋅⇩p ℐ = d ⋅⇩p ℐ" unfolding pair_def by (induct Di) auto
from *(2) have 2: "∀d ∈ set D - set Di. (t,s) ⋅⇩p ℐ ≠ d ⋅⇩p ℐ"
proof (induction D arbitrary: Di)
case (Cons d D) thus ?case
proof (cases "d ∈ set Di")
case False
hence IH: "∀d ∈ set D - set Di. (t,s) ⋅⇩p ℐ ≠ d ⋅⇩p ℐ" using Cons by force
have "⋀t (δ::('fun,'var) subst). subst_domain δ = {} ∧ ground (subst_range δ) ⟷ δ = Var"
by auto
moreover have "ineq_model ℐ [] [((pair (t,s)), (pair d))]"
using False Cons.prems by simp
ultimately have "pair (t,s) ⋅ ℐ ≠ pair d ⋅ ℐ" by (simp add: ineq_model_def)
thus ?thesis using IH unfolding pair_def by force
qed simp
qed simp
show ?thesis by (metis 1 2)
qed
private lemma tr_Delete_constr_iff:
fixes ℐ::"('fun,'var) subst"
assumes "ground M"
shows "set Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {(t,s) ⋅⇩p ℐ} ∧ (t,s) ⋅⇩p ℐ ∉ (set D - set Di) ⋅⇩p⇩s⇩e⇩t ℐ ⟷
⟦M; (map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di])⟧⇩d ℐ"
proof -
let ?constr = "(map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di)@
(map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di])"
{ assume "set Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {(t,s) ⋅⇩p ℐ}" "(t,s) ⋅⇩p ℐ ∉ (set D - set Di) ⋅⇩p⇩s⇩e⇩t ℐ"
hence "∀d ∈ set Di. (t,s) ⋅⇩p ℐ = d ⋅⇩p ℐ" "∀d ∈ set D - set Di. (t,s) ⋅⇩p ℐ ≠ d ⋅⇩p ℐ"
by auto
hence "⟦M; ?constr⟧⇩d ℐ" using tr_Delete_constr_iff_aux1 by simp
} moreover {
assume "⟦M; ?constr⟧⇩d ℐ"
hence "∀d ∈ set Di. (t,s) ⋅⇩p ℐ = d ⋅⇩p ℐ" "∀d ∈ set D - set Di. (t,s) ⋅⇩p ℐ ≠ d ⋅⇩p ℐ"
using assms tr_Delete_constr_iff_aux2 by auto
hence "set Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {(t,s) ⋅⇩p ℐ} ∧ (t,s) ⋅⇩p ℐ ∉ (set D - set Di) ⋅⇩p⇩s⇩e⇩t ℐ" by force
} ultimately show ?thesis by metis
qed
private lemma tr_NotInSet_constr_iff:
fixes ℐ::"('fun,'var) subst"
assumes "∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ set X = {}"
shows "(∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶ (t,s) ⋅⇩p δ ⋅⇩p ℐ ∉ set D ⋅⇩p⇩s⇩e⇩t ℐ)
⟷ ⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) D⟧⇩d ℐ"
proof -
{ assume "∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶ (t,s) ⋅⇩p δ ⋅⇩p ℐ ∉ set D ⋅⇩p⇩s⇩e⇩t ℐ"
with assms have "⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) D⟧⇩d ℐ"
proof (induction D)
case (Cons d D)
obtain t' s' where d: "d = (t',s')" by moura
have "⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) D⟧⇩d ℐ"
"map (λd. ∀X⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) (d#D) =
∀X⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t#map (λd. ∀X⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) D"
using Cons by auto
moreover have
"∀δ. subst_domain δ = set X ∧ ground (subst_range δ) ⟶ pair (t, s) ⋅ δ ⋅ ℐ ≠ pair d ⋅ ℐ"
using fun_pair_ineqs[of ℐ _ "(t,s)" ℐ d] Cons.prems(2) by auto
moreover have "(fv t' ∪ fv s') ∩ set X = {}" using Cons.prems(1) d by auto
hence "∀δ. subst_domain δ = set X ⟶ pair d ⋅ δ = pair d" using d unfolding pair_def by auto
ultimately show ?case by (simp add: ineq_model_def)
qed simp
} moreover {
fix δ::"('fun,'var) subst"
assume "⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) D⟧⇩d ℐ"
and δ: "subst_domain δ = set X" "ground (subst_range δ)"
with assms have "(t,s) ⋅⇩p δ ⋅⇩p ℐ ∉ set D ⋅⇩p⇩s⇩e⇩t ℐ"
proof (induction D)
case (Cons d D)
obtain t' s' where d: "d = (t',s')" by moura
have "(t,s) ⋅⇩p δ ⋅⇩p ℐ ∉ set D ⋅⇩p⇩s⇩e⇩t ℐ"
"pair (t,s) ⋅ δ ⋅ ℐ ≠ pair d ⋅ δ ⋅ ℐ"
using Cons d by (auto simp add: ineq_model_def simp del: subst_range.simps)
moreover have "pair d ⋅ δ = pair d"
using Cons.prems(1) fun_pair_subst[of d δ] d δ(1) unfolding pair_def by auto
ultimately show ?case unfolding pair_def by force
qed simp
} ultimately show ?thesis by metis
qed
lemma tr_NegChecks_constr_iff:
"(∀G∈set L. ineq_model ℐ X (F@G)) ⟷ ⟦M; map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) L⟧⇩d ℐ" (is ?A)
"negchecks_model ℐ D X F F' ⟷ ⟦M; D; [∀X⟨∨≠: F ∨∉: F'⟩]⟧⇩s ℐ" (is ?B)
proof -
show ?A by (induct L) auto
show ?B by simp
qed
lemma tr⇩p⇩a⇩i⇩r⇩s_sem_equiv:
fixes ℐ::"('fun,'var) subst"
assumes "∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ set X = {}"
shows "negchecks_model ℐ (set D ⋅⇩p⇩s⇩e⇩t ℐ) X F F' ⟷
(∀G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D). ineq_model ℐ X (F@G))"
proof -
define P where
"P ≡ λδ::('fun,'var) subst. subst_domain δ = set X ∧ ground (subst_range δ)"
define Ineq where
"Ineq ≡ λ(δ::('fun,'var) subst) F. list_ex (λf. fst f ⋅ δ ∘⇩s ℐ ≠ snd f ⋅ δ ∘⇩s ℐ) F"
define Ineq' where
"Ineq' ≡ λ(δ::('fun,'var) subst) F. list_ex (λf. fst f ⋅ δ ∘⇩s ℐ ≠ snd f ⋅ ℐ) F"
define Notin where
"Notin ≡ λ(δ::('fun,'var) subst) D F'. list_ex (λf. f ⋅⇩p δ ∘⇩s ℐ ∉ set D ⋅⇩p⇩s⇩e⇩t ℐ) F'"
have sublmm:
"((s,t) ⋅⇩p δ ∘⇩s ℐ ∉ set D ⋅⇩p⇩s⇩e⇩t ℐ) ⟷ (list_all (λd. Ineq' δ [(pair (s,t),pair d)]) D)"
for s t δ D
unfolding pair_def by (induct D) (auto simp add: Ineq'_def)
have "Notin δ D F' ⟷ (∀G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D). Ineq' δ G)"
(is "?A ⟷ ?B")
when "P δ" for δ
proof
show "?A ⟹ ?B"
proof (induction F' D rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F' D)
show ?case
proof (cases "Notin δ D F'")
case False
hence "(s,t) ⋅⇩p δ ∘⇩s ℐ ∉ set D ⋅⇩p⇩s⇩e⇩t ℐ"
using "2.prems"
by (auto simp add: Notin_def)
hence "pair (s,t) ⋅ δ ∘⇩s ℐ ≠ pair d ⋅ ℐ" when "d ∈ set D" for d
using that sublmm Ball_set[of D "λd. Ineq' δ [(pair (s,t), pair d)]"]
by (simp add: Ineq'_def)
moreover have "∃d ∈ set D. ∃G'. G = (pair (s,t), pair d)#G'"
when "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s ((s,t)#F') D)" for G
using that tr⇩p⇩a⇩i⇩r⇩s_index[OF that, of 0] by force
ultimately show ?thesis by (simp add: Ineq'_def)
qed (auto dest: "2.IH" simp add: Ineq'_def)
qed (simp add: Notin_def)
have "¬?A ⟹ ¬?B"
proof (induction F' D rule: tr⇩p⇩a⇩i⇩r⇩s.induct)
case (2 s t F' D)
then obtain G where G: "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D)" "¬Ineq' δ G"
by (auto simp add: Notin_def)
obtain d where d: "d ∈ set D" "pair (s,t) ⋅ δ ∘⇩s ℐ = pair d ⋅ ℐ"
using "2.prems"
unfolding pair_def by (auto simp add: Notin_def)
thus ?case
using G(2) tr⇩p⇩a⇩i⇩r⇩s_cons[OF G(1) d(1)]
by (auto simp add: Ineq'_def)
qed (simp add: Ineq'_def)
thus "?B ⟹ ?A" by metis
qed
hence *: "(∀δ. P δ ⟶ Ineq δ F ∨ Notin δ D F') ⟷
(∀G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D). ∀δ. P δ ⟶ Ineq δ F ∨ Ineq' δ G)"
by auto
have "snd g ⋅ δ = snd g"
when "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D)" "g ∈ set G" "P δ"
for δ g G
using assms that(3) tr⇩p⇩a⇩i⇩r⇩s_has_pair_lists[OF that(1,2)]
unfolding pair_def by (fastforce simp add: P_def)
hence **: "Ineq' δ G = Ineq δ G"
when "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' D)" "P δ"
for δ G
using Bex_set[of G "λf. fst f ⋅ δ ∘⇩s ℐ ≠ snd f ⋅ ℐ"]
Bex_set[of G "λf. fst f ⋅ δ ∘⇩s ℐ ≠ snd f ⋅ δ ∘⇩s ℐ"]
that
by (simp add: Ineq_def Ineq'_def)
show ?thesis
using * **
by (simp add: Ineq_def Ineq'_def Notin_def P_def negchecks_model_def ineq_model_def)
qed
lemma tr_sem_equiv':
assumes "∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
and "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}"
and "ground M"
and ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ ⟷ (∃A' ∈ set (tr A D). ⟦M; A'⟧⇩d ℐ)" (is "?P ⟷ ?Q")
proof
have ℐ_grounds: "⋀t. fv (t ⋅ ℐ) = {}" by (rule interpretation_grounds[OF ℐ])
have "∃A' ∈ set (tr A D). ⟦M; A'⟧⇩d ℐ" when ?P using that assms(1,2,3)
proof (induction A arbitrary: D rule: strand_sem_stateful_induct)
case (ConsRcv M D t A)
have "⟦insert (t ⋅ ℐ) M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground (insert (t ⋅ ℐ) M)"
using ℐ ConsRcv.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
then obtain A' where A': "A' ∈ set (tr A D)" "⟦insert (t ⋅ ℐ) M; A'⟧⇩d ℐ" by (metis ConsRcv.IH)
thus ?case by auto
next
case (ConsSnd M D t A)
have "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
and *: "M ⊢ t ⋅ ℐ"
using ℐ ConsSnd.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
then obtain A' where A': "A' ∈ set (tr A D)" "⟦M; A'⟧⇩d ℐ" by (metis ConsSnd.IH)
thus ?case using * by auto
next
case (ConsEq M D ac t t' A)
have "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
and *: "t ⋅ ℐ = t' ⋅ ℐ"
using ℐ ConsEq.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
then obtain A' where A': "A' ∈ set (tr A D)" "⟦M; A'⟧⇩d ℐ" by (metis ConsEq.IH)
thus ?case using * by auto
next
case (ConsIns M D t s A)
have "⟦M; set (List.insert (t,s) D) ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
"∀(t,t') ∈ set (List.insert (t,s) D). (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
using ConsIns.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
then obtain A' where A': "A' ∈ set (tr A (List.insert (t,s) D))" "⟦M; A'⟧⇩d ℐ"
by (metis ConsIns.IH)
thus ?case by auto
next
case (ConsDel M D t s A)
have *: "⟦M; (set D ⋅⇩p⇩s⇩e⇩t ℐ) - {(t,s) ⋅⇩p ℐ}; A⟧⇩s ℐ"
"∀(t,t')∈set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
using ConsDel.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
then obtain Di where Di:
"Di ⊆ set D" "Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {(t,s) ⋅⇩p ℐ}" "(t,s) ⋅⇩p ℐ ∉ (set D - Di) ⋅⇩p⇩s⇩e⇩t ℐ"
using subset_subst_pairs_diff_exists'[of "set D"] by moura
hence **: "(set D ⋅⇩p⇩s⇩e⇩t ℐ) - {(t,s) ⋅⇩p ℐ} = (set D - Di) ⋅⇩p⇩s⇩e⇩t ℐ" by blast
obtain Di' where Di': "set Di' = Di" "Di' ∈ set (subseqs D)"
using subset_sublist_exists[OF Di(1)] by moura
hence ***: "(set D ⋅⇩p⇩s⇩e⇩t ℐ) - {(t,s) ⋅⇩p ℐ} = (set [d←D. d ∉ set Di'] ⋅⇩p⇩s⇩e⇩t ℐ)"
using Di ** by auto
define constr where "constr ≡
map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di'@
map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di']"
have ****: "∀(t,t')∈set [d←D. d ∉ set Di']. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
using *(2) Di(1) Di'(1) subseqs_set_subset[OF Di'(2)] by simp
have "set D - Di = set [d←D. d ∉ set Di']" using Di Di' by auto
hence *****: "⟦M; set [d←D. d ∉ set Di'] ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
using *(1) ** by metis
obtain A' where A': "A' ∈ set (tr A [d←D. d ∉ set Di'])" "⟦M; A'⟧⇩d ℐ"
using ConsDel.IH[OF ***** **** *(3,4)] by moura
hence constr_sat: "⟦M; constr⟧⇩d ℐ"
using Di Di' *(1) *** tr_Delete_constr_iff[OF *(4), of ℐ Di' t s D]
unfolding constr_def by auto
have "constr@A' ∈ set (tr (Delete t s#A) D)" using A'(1) Di' unfolding constr_def by auto
moreover have "ik⇩s⇩t constr = {}" unfolding constr_def by auto
hence "⟦M ⋅⇩s⇩e⇩t ℐ; constr⟧⇩d ℐ" "⟦M ∪ (ik⇩s⇩t constr ⋅⇩s⇩e⇩t ℐ); A'⟧⇩d ℐ"
using constr_sat A'(2) subst_all_ground_ident[OF *(4)] by simp_all
ultimately show ?case
using strand_sem_append(2)[of _ _ ℐ]
subst_all_ground_ident[OF *(4), of ℐ]
by metis
next
case (ConsIn M D ac t s A)
have "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
and *: "(t,s) ⋅⇩p ℐ ∈ set D ⋅⇩p⇩s⇩e⇩t ℐ"
using ℐ ConsIn.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
then obtain A' where A': "A' ∈ set (tr A D)" "⟦M; A'⟧⇩d ℐ" by (metis ConsIn.IH)
moreover obtain d where "d ∈ set D" "pair (t,s) ⋅ ℐ = pair d ⋅ ℐ"
using * unfolding pair_def by auto
ultimately show ?case using * by auto
next
case (ConsNegChecks M D X F F' A)
let ?ineqs = "(map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D))"
have 1: "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ" "ground M" using ConsNegChecks by auto
have 2: "∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}" "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}"
using ConsNegChecks.prems(2,3) ℐ unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by fastforce+
have 3: "negchecks_model ℐ (set D ⋅⇩p⇩s⇩e⇩t ℐ) X F F'" using ConsNegChecks.prems(1) by simp
from 1 2 obtain A' where A': "A' ∈ set (tr A D)" "⟦M; A'⟧⇩d ℐ" by (metis ConsNegChecks.IH)
have 4: "∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ set X = {}"
using ConsNegChecks.prems(2) unfolding bvars⇩s⇩s⇩t_def by auto
have "⟦M; ?ineqs⟧⇩d ℐ"
using 3 tr⇩p⇩a⇩i⇩r⇩s_sem_equiv[OF 4] tr_NegChecks_constr_iff
by metis
moreover have "ik⇩s⇩t ?ineqs = {}" by auto
moreover have "M ⋅⇩s⇩e⇩t ℐ = M" using 1(2) ℐ by (simp add: subst_all_ground_ident)
ultimately show ?case
using strand_sem_append(2)[of M ?ineqs ℐ A'] A'
by force
qed simp
thus "?P ⟹ ?Q" by metis
have "(∃A' ∈ set (tr A D). ⟦M; A'⟧⇩d ℐ) ⟹ ?P" using assms(1,2,3)
proof (induction A arbitrary: D rule: strand_sem_stateful_induct)
case (ConsRcv M D t A)
have "∃A' ∈ set (tr A D). ⟦insert (t ⋅ ℐ) M; A'⟧⇩d ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground (insert (t ⋅ ℐ) M)"
using ℐ ConsRcv.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
hence "⟦insert (t ⋅ ℐ) M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ" by (metis ConsRcv.IH)
thus ?case by auto
next
case (ConsSnd M D t A)
have "∃A' ∈ set (tr A D). ⟦M; A'⟧⇩d ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
and *: "M ⊢ t ⋅ ℐ"
using ℐ ConsSnd.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
hence "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ" by (metis ConsSnd.IH)
thus ?case using * by auto
next
case (ConsEq M D ac t t' A)
have "∃A' ∈ set (tr A D). ⟦M; A'⟧⇩d ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
and *: "t ⋅ ℐ = t' ⋅ ℐ"
using ℐ ConsEq.prems unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
hence "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ" by (metis ConsEq.IH)
thus ?case using * by auto
next
case (ConsIns M D t s A)
hence "∃A' ∈ set (tr A (List.insert (t,s) D)). ⟦M; A'⟧⇩d ℐ"
"∀(t,t') ∈ set (List.insert (t,s) D). (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by auto+
hence "⟦M; set (List.insert (t,s) D) ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ" by (metis ConsIns.IH)
thus ?case by auto
next
case (ConsDel M D t s A)
define constr where "constr ≡
λDi. map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di@
map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←D. d ∉ set Di]"
let ?flt = "λDi. filter (λd. d ∉ set Di) D"
have "∃Di ∈ set (subseqs D). ∃B' ∈ set (tr A (?flt Di)). B = constr Di@B'"
when "B ∈ set (tr (delete⟨t,s⟩#A) D)" for B
using that unfolding constr_def by auto
then obtain A' Di where A':
"constr Di@A' ∈ set (tr (Delete t s#A) D)"
"A' ∈ set (tr A (?flt Di))"
"Di ∈ set (subseqs D)"
"⟦M; constr Di@A'⟧⇩d ℐ"
using ConsDel.prems(1) by blast
have 1: "∀(t,t')∈set (?flt Di). (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}" using ConsDel.prems(2) by auto
have 2: "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" using ConsDel.prems(3) by force+
have "ik⇩s⇩t (constr Di) = {}" unfolding constr_def by auto
hence 3: "⟦M; A'⟧⇩d ℐ"
using subst_all_ground_ident[OF ConsDel.prems(4)] A'(4)
strand_sem_split(4)[of M "constr Di" A' ℐ]
by simp
have IH: "⟦M; set (?flt Di) ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
by (metis ConsDel.IH[OF _ 1 2 ConsDel.prems(4)] 3 A'(2))
have "⟦M; constr Di⟧⇩d ℐ"
using subst_all_ground_ident[OF ConsDel.prems(4)] strand_sem_split(3) A'(4)
by metis
hence *: "set Di ⋅⇩p⇩s⇩e⇩t ℐ ⊆ {(t,s) ⋅⇩p ℐ}" "(t,s) ⋅⇩p ℐ ∉ (set D - set Di) ⋅⇩p⇩s⇩e⇩t ℐ"
using tr_Delete_constr_iff[OF ConsDel.prems(4), of ℐ Di t s D] unfolding constr_def by auto
have 4: "set (?flt Di) ⋅⇩p⇩s⇩e⇩t ℐ = (set D ⋅⇩p⇩s⇩e⇩t ℐ) - {((t,s) ⋅⇩p ℐ)}"
proof
show "set (?flt Di) ⋅⇩p⇩s⇩e⇩t ℐ ⊆ (set D ⋅⇩p⇩s⇩e⇩t ℐ) - {((t,s) ⋅⇩p ℐ)}"
proof
fix u u' assume u: "(u,u') ∈ set (?flt Di) ⋅⇩p⇩s⇩e⇩t ℐ"
then obtain v v' where v: "(v,v') ∈ set D - set Di" "(v,v') ⋅⇩p ℐ = (u,u')" by auto
hence "(u,u') ≠ (t,s) ⋅⇩p ℐ" using * by force
thus "(u,u') ∈ (set D ⋅⇩p⇩s⇩e⇩t ℐ) - {((t,s) ⋅⇩p ℐ)}"
using u v * subseqs_set_subset[OF A'(3)] by auto
qed
show "(set D ⋅⇩p⇩s⇩e⇩t ℐ) - {((t,s) ⋅⇩p ℐ)} ⊆ set (?flt Di) ⋅⇩p⇩s⇩e⇩t ℐ"
using * subseqs_set_subset[OF A'(3)] by force
qed
show ?case using 4 IH by simp
next
case (ConsIn M D ac t s A)
have "∃A' ∈ set (tr A D). ⟦M; A'⟧⇩d ℐ"
"∀(t,t') ∈ set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}"
"fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" "ground M"
and *: "(t,s) ⋅⇩p ℐ ∈ set D ⋅⇩p⇩s⇩e⇩t ℐ"
using ConsIn.prems(1,2,3,4) apply (fastforce, fastforce, fastforce, fastforce)
using ConsIn.prems(1) tr.simps(7)[of ac t s A D] unfolding pair_def by fastforce
hence "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ" by (metis ConsIn.IH)
moreover obtain d where "d ∈ set D" "pair (t,s) ⋅ ℐ = pair d ⋅ ℐ"
using * unfolding pair_def by auto
ultimately show ?case using * by auto
next
case (ConsNegChecks M D X F F' A)
let ?ineqs = "(map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' D))"
obtain B where B:
"?ineqs@B ∈ set (tr (NegChecks X F F'#A) D)" "⟦M; ?ineqs@B⟧⇩d ℐ" "B ∈ set (tr A D)"
using ConsNegChecks.prems(1) by moura
moreover have "M ⋅⇩s⇩e⇩t ℐ = M"
using ConsNegChecks.prems(4) ℐ by (simp add: subst_all_ground_ident)
moreover have "ik⇩s⇩t ?ineqs = {}" by auto
ultimately have "⟦M; B⟧⇩d ℐ" using strand_sem_split(4)[of M ?ineqs B ℐ] by simp
moreover have "∀(t,t')∈set D. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t A = {}" "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}"
using ConsNegChecks.prems(2,3) unfolding fv⇩s⇩s⇩t_def bvars⇩s⇩s⇩t_def by force+
ultimately have "⟦M; set D ⋅⇩p⇩s⇩e⇩t ℐ; A⟧⇩s ℐ"
by (metis ConsNegChecks.IH B(3) ConsNegChecks.prems(4))
moreover have "∀(t, t')∈set D. (fv t ∪ fv t') ∩ set X = {}"
using ConsNegChecks.prems(2) unfolding bvars⇩s⇩s⇩t_def by force
ultimately show ?case
using tr⇩p⇩a⇩i⇩r⇩s_sem_equiv tr_NegChecks_constr_iff
B(2) strand_sem_split(3)[of M ?ineqs B ℐ] ‹M ⋅⇩s⇩e⇩t ℐ = M›
by simp
qed simp
thus "?Q ⟹ ?P" by metis
qed
lemma tr_sem_equiv:
assumes "fv⇩s⇩s⇩t A ∩ bvars⇩s⇩s⇩t A = {}" and "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "ℐ ⊨⇩s A ⟷ (∃A' ∈ set (tr A []). (ℐ ⊨ ⟨A'⟩))"
using tr_sem_equiv'[OF _ assms(1) _ assms(2), of "[]" "{}"]
unfolding constr_sem_d_def
by auto
theorem stateful_typing_result:
assumes "wf⇩s⇩s⇩t 𝒜"
and "tfr⇩s⇩s⇩t 𝒜"
and "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t 𝒜)"
and "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and "ℐ ⊨⇩s 𝒜"
obtains ℐ⇩τ
where "interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ"
and "ℐ⇩τ ⊨⇩s 𝒜"
and "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ"
and "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
proof -
obtain 𝒜' where 𝒜':
"𝒜' ∈ set (tr 𝒜 [])" "ℐ ⊨ ⟨𝒜'⟩"
using tr_sem_equiv[of 𝒜] assms(1,4,5)
by auto
have *: "wf⇩s⇩t {} 𝒜'"
"fv⇩s⇩t 𝒜' ∩ bvars⇩s⇩t 𝒜' = {}"
"tfr⇩s⇩t 𝒜'" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩t 𝒜')"
using tr_wf[OF 𝒜'(1) assms(1,3)]
tr_tfr[OF 𝒜'(1) assms(2)] assms(1)
by metis+
obtain ℐ⇩τ where ℐ⇩τ:
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "⟦{}; 𝒜'⟧⇩d ℐ⇩τ"
"wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
using wt_attack_if_tfr_attack_d
* Ana_invar_subst' assms(4)
𝒜'(2)
unfolding constr_sem_d_def
by moura
thus ?thesis
using that tr_sem_equiv[of 𝒜] assms(1,3) 𝒜'(1)
unfolding constr_sem_d_def
by auto
qed
end
end
subsection ‹Proving type-flaw resistance automatically›
definition pair' where
"pair' pair_fun d ≡ case d of (t,t') ⇒ Fun pair_fun [t,t']"
fun comp_tfr⇩s⇩s⇩t⇩p where
"comp_tfr⇩s⇩s⇩t⇩p Γ pair_fun (⟨_: t ≐ t'⟩) = (mgu t t' ≠ None ⟶ Γ t = Γ t')"
| "comp_tfr⇩s⇩s⇩t⇩p Γ pair_fun (∀X⟨∨≠: F ∨∉: F'⟩) = (
(F' = [] ∧ (∀x ∈ fv⇩p⇩a⇩i⇩r⇩s F - set X. is_Var (Γ (Var x)))) ∨
(∀u ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair' pair_fun ` set F').
is_Fun u ⟶ (args u = [] ∨ (∃s ∈ set (args u). s ∉ Var ` set X))))"
| "comp_tfr⇩s⇩s⇩t⇩p _ _ _ = True"
definition comp_tfr⇩s⇩s⇩t where
"comp_tfr⇩s⇩s⇩t arity Ana Γ pair_fun M S ≡
list_all (comp_tfr⇩s⇩s⇩t⇩p Γ pair_fun) S ∧
list_all (wf⇩t⇩r⇩m' arity) (trms_list⇩s⇩s⇩t S) ∧
has_all_wt_instances_of Γ (trms⇩s⇩s⇩t S ∪ pair' pair_fun ` setops⇩s⇩s⇩t S) (set M) ∧
comp_tfr⇩s⇩e⇩t arity Ana Γ M"
locale stateful_typed_model' = stateful_typed_model arity public Ana Γ Pair
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
⇒ (('fun,(('fun,'atom) term_type × nat)) term list
× ('fun,(('fun,'atom) term_type × nat)) term list)"
and Γ::"('fun,(('fun,'atom) term_type × nat)) term ⇒ ('fun,'atom) term_type"
and Pair::"'fun"
+
assumes Γ_Var_fst': "⋀τ n m. Γ (Var (τ,n)) = Γ (Var (τ,m))"
and Ana_const': "⋀c T. arity c = 0 ⟹ Ana (Fun c T) = ([], [])"
begin
sublocale typed_model'
by (unfold_locales, rule Γ_Var_fst', metis Ana_const', metis Ana_subst')
lemma pair_code:
"pair d = pair' Pair d"
by (simp add: pair_def pair'_def)
lemma tfr⇩s⇩s⇩t⇩p_is_comp_tfr⇩s⇩s⇩t⇩p: "tfr⇩s⇩s⇩t⇩p a = comp_tfr⇩s⇩s⇩t⇩p Γ Pair a"
proof (cases a)
case (Equality ac t t')
thus ?thesis
using mgu_always_unifies[of t _ t'] mgu_gives_MGU[of t t']
by auto
next
case (NegChecks X F F')
thus ?thesis
using tfr⇩s⇩s⇩t⇩p.simps(2)[of X F F']
comp_tfr⇩s⇩s⇩t⇩p.simps(2)[of Γ Pair X F F']
Fun_range_case(2)[of "subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F')"]
unfolding is_Var_def pair_code[symmetric]
by auto
qed auto
lemma tfr⇩s⇩s⇩t_if_comp_tfr⇩s⇩s⇩t:
assumes "comp_tfr⇩s⇩s⇩t arity Ana Γ Pair M S"
shows "tfr⇩s⇩s⇩t S"
unfolding tfr⇩s⇩s⇩t_def
proof
have comp_tfr⇩s⇩e⇩t_M: "comp_tfr⇩s⇩e⇩t arity Ana Γ M"
using assms unfolding comp_tfr⇩s⇩s⇩t_def by blast
have wf⇩t⇩r⇩m⇩s_M: "wf⇩t⇩r⇩m⇩s (set M)"
and wf⇩t⇩r⇩m⇩s_S: "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t S ∪ pair ` setops⇩s⇩s⇩t S)"
and S_trms_instance_M: "has_all_wt_instances_of Γ (trms⇩s⇩s⇩t S ∪ pair ` setops⇩s⇩s⇩t S) (set M)"
using assms setops⇩s⇩s⇩t_wf⇩t⇩r⇩m⇩s(2)[of S] trms_list⇩s⇩s⇩t_is_trms⇩s⇩s⇩t[of S]
unfolding comp_tfr⇩s⇩s⇩t_def comp_tfr⇩s⇩e⇩t_def list_all_iff pair_code[symmetric] wf⇩t⇩r⇩m_code[symmetric]
finite_SMP_representation_def
by (meson, meson, blast, meson)
show "tfr⇩s⇩e⇩t (trms⇩s⇩s⇩t S ∪ pair ` setops⇩s⇩s⇩t S)"
using tfr_subset(3)[OF tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t[OF comp_tfr⇩s⇩e⇩t_M] SMP_SMP_subset]
SMP_I'[OF wf⇩t⇩r⇩m⇩s_S wf⇩t⇩r⇩m⇩s_M S_trms_instance_M]
by blast
have "list_all (comp_tfr⇩s⇩s⇩t⇩p Γ Pair) S" by (metis assms comp_tfr⇩s⇩s⇩t_def)
thus "list_all tfr⇩s⇩s⇩t⇩p S" by (induct S) (simp_all add: tfr⇩s⇩s⇩t⇩p_is_comp_tfr⇩s⇩s⇩t⇩p)
qed
lemma tfr⇩s⇩s⇩t_if_comp_tfr⇩s⇩s⇩t':
assumes "comp_tfr⇩s⇩s⇩t arity Ana Γ Pair (SMP0 Ana Γ (trms_list⇩s⇩s⇩t S@map pair (setops_list⇩s⇩s⇩t S))) S"
shows "tfr⇩s⇩s⇩t S"
by (rule tfr⇩s⇩s⇩t_if_comp_tfr⇩s⇩s⇩t[OF assms])
end
end
Theory Labeled_Strands
section ‹Labeled Strands›
theory Labeled_Strands
imports Strands_and_Constraints
begin
subsection ‹Definitions: Labeled Strands and Constraints›
datatype 'l strand_label =
LabelN (the_LabelN: "'l") ("ln _")
| LabelS ("⋆")
text ‹Labeled strands are strands whose steps are equipped with labels›
type_synonym ('a,'b,'c) labeled_strand_step = "'c strand_label × ('a,'b) strand_step"
type_synonym ('a,'b,'c) labeled_strand = "('a,'b,'c) labeled_strand_step list"
abbreviation is_LabelN where "is_LabelN n x ≡ fst x = ln n"
abbreviation is_LabelS where "is_LabelS x ≡ fst x = ⋆"
definition unlabel where "unlabel S ≡ map snd S"
definition proj where "proj n S ≡ filter (λs. is_LabelN n s ∨ is_LabelS s) S"
abbreviation proj_unl where "proj_unl n S ≡ unlabel (proj n S)"
abbreviation wfrestrictedvars⇩l⇩s⇩t where "wfrestrictedvars⇩l⇩s⇩t S ≡ wfrestrictedvars⇩s⇩t (unlabel S)"
abbreviation subst_apply_labeled_strand_step (infix "⋅⇩l⇩s⇩t⇩p" 51) where
"x ⋅⇩l⇩s⇩t⇩p θ ≡ (case x of (l, s) ⇒ (l, s ⋅⇩s⇩t⇩p θ))"
abbreviation subst_apply_labeled_strand (infix "⋅⇩l⇩s⇩t" 51) where
"S ⋅⇩l⇩s⇩t θ ≡ map (λx. x ⋅⇩l⇩s⇩t⇩p θ) S"
abbreviation trms⇩l⇩s⇩t where "trms⇩l⇩s⇩t S ≡ trms⇩s⇩t (unlabel S)"
abbreviation trms_proj⇩l⇩s⇩t where "trms_proj⇩l⇩s⇩t n S ≡ trms⇩s⇩t (proj_unl n S)"
abbreviation vars⇩l⇩s⇩t where "vars⇩l⇩s⇩t S ≡ vars⇩s⇩t (unlabel S)"
abbreviation vars_proj⇩l⇩s⇩t where "vars_proj⇩l⇩s⇩t n S ≡ vars⇩s⇩t (proj_unl n S)"
abbreviation bvars⇩l⇩s⇩t where "bvars⇩l⇩s⇩t S ≡ bvars⇩s⇩t (unlabel S)"
abbreviation fv⇩l⇩s⇩t where "fv⇩l⇩s⇩t S ≡ fv⇩s⇩t (unlabel S)"
abbreviation wf⇩l⇩s⇩t where "wf⇩l⇩s⇩t V S ≡ wf⇩s⇩t V (unlabel S)"
subsection ‹Lemmata: Projections›
lemma is_LabelS_proj_iff_not_is_LabelN:
"list_all is_LabelS (proj l A) ⟷ ¬list_ex (is_LabelN l) A"
by (induct A) (auto simp add: proj_def)
lemma proj_subset_if_no_label:
assumes "¬list_ex (is_LabelN l) A"
shows "set (proj l A) ⊆ set (proj l' A)"
and "set (proj_unl l A) ⊆ set (proj_unl l' A)"
using assms by (induct A) (auto simp add: unlabel_def proj_def)
lemma proj_in_setD:
assumes a: "a ∈ set (proj l A)"
obtains k b where "a = (k, b)" "k = (ln l) ∨ k = ⋆"
using that a unfolding proj_def by (cases a) auto
lemma proj_set_mono:
assumes "set A ⊆ set B"
shows "set (proj n A) ⊆ set (proj n B)"
and "set (proj_unl n A) ⊆ set (proj_unl n B)"
using assms unfolding proj_def unlabel_def by auto
lemma unlabel_nil[simp]: "unlabel [] = []"
by (simp add: unlabel_def)
lemma unlabel_mono: "set A ⊆ set B ⟹ set (unlabel A) ⊆ set (unlabel B)"
by (auto simp add: unlabel_def)
lemma unlabel_in: "(l,x) ∈ set A ⟹ x ∈ set (unlabel A)"
unfolding unlabel_def by force
lemma unlabel_mem_has_label: "x ∈ set (unlabel A) ⟹ ∃l. (l,x) ∈ set A"
unfolding unlabel_def by auto
lemma proj_nil[simp]: "proj n [] = []" "proj_unl n [] = []"
unfolding unlabel_def proj_def by auto
lemma singleton_lst_proj[simp]:
"proj_unl l [(ln l, a)] = [a]"
"l ≠ l' ⟹ proj_unl l' [(ln l, a)] = []"
"proj_unl l [(⋆, a)] = [a]"
"unlabel [(l'', a)] = [a]"
unfolding proj_def unlabel_def by simp_all
lemma unlabel_nil_only_if_nil[simp]: "unlabel A = [] ⟹ A = []"
unfolding unlabel_def by auto
lemma unlabel_Cons[simp]:
"unlabel ((l,a)#A) = a#unlabel A"
"unlabel (b#A) = snd b#unlabel A"
unfolding unlabel_def by simp_all
lemma unlabel_append[simp]: "unlabel (A@B) = unlabel A@unlabel B"
unfolding unlabel_def by auto
lemma proj_Cons[simp]:
"proj n ((ln n,a)#A) = (ln n,a)#proj n A"
"proj n ((⋆,a)#A) = (⋆,a)#proj n A"
"m ≠ n ⟹ proj n ((ln m,a)#A) = proj n A"
"l = (ln n) ⟹ proj n ((l,a)#A) = (l,a)#proj n A"
"l = ⋆ ⟹ proj n ((l,a)#A) = (l,a)#proj n A"
"fst b ≠ ⋆ ⟹ fst b ≠ (ln n) ⟹ proj n (b#A) = proj n A"
unfolding proj_def by auto
lemma proj_append[simp]:
"proj l (A'@B') = proj l A'@proj l B'"
"proj_unl l (A@B) = proj_unl l A@proj_unl l B"
unfolding proj_def unlabel_def by auto
lemma proj_unl_cons[simp]:
"proj_unl l ((ln l, a)#A) = a#proj_unl l A"
"l ≠ l' ⟹ proj_unl l' ((ln l, a)#A) = proj_unl l' A"
"proj_unl l ((⋆, a)#A) = a#proj_unl l A"
unfolding proj_def unlabel_def by simp_all
lemma trms_unlabel_proj[simp]:
"trms⇩s⇩t⇩p (snd (ln l, x)) ⊆ trms_proj⇩l⇩s⇩t l [(ln l, x)]"
by auto
lemma trms_unlabel_star[simp]:
"trms⇩s⇩t⇩p (snd (⋆, x)) ⊆ trms_proj⇩l⇩s⇩t l [(⋆, x)]"
by auto
lemma trms⇩l⇩s⇩t_union[simp]: "trms⇩l⇩s⇩t A = (⋃l. trms_proj⇩l⇩s⇩t l A)"
proof (induction A)
case (Cons a A)
obtain l s where ls: "a = (l,s)" by moura
have "trms⇩l⇩s⇩t [a] = (⋃l. trms_proj⇩l⇩s⇩t l [a])"
proof -
have *: "trms⇩l⇩s⇩t [a] = trms⇩s⇩t⇩p s" using ls by simp
show ?thesis
proof (cases l)
case (LabelN n)
hence "trms_proj⇩l⇩s⇩t n [a] = trms⇩s⇩t⇩p s" using ls by simp
moreover have "∀m. n ≠ m ⟶ trms_proj⇩l⇩s⇩t m [a] = {}" using ls LabelN by auto
ultimately show ?thesis using * ls by fastforce
next
case LabelS
hence "∀l. trms_proj⇩l⇩s⇩t l [a] = trms⇩s⇩t⇩p s" using ls by auto
thus ?thesis using * ls by fastforce
qed
qed
moreover have "∀l. trms_proj⇩l⇩s⇩t l (a#A) = trms_proj⇩l⇩s⇩t l [a] ∪ trms_proj⇩l⇩s⇩t l A"
unfolding unlabel_def proj_def by auto
hence "(⋃l. trms_proj⇩l⇩s⇩t l (a#A)) = (⋃l. trms_proj⇩l⇩s⇩t l [a]) ∪ (⋃l. trms_proj⇩l⇩s⇩t l A)" by auto
ultimately show ?case using Cons.IH ls by auto
qed simp
lemma trms⇩l⇩s⇩t_append[simp]: "trms⇩l⇩s⇩t (A@B) = trms⇩l⇩s⇩t A ∪ trms⇩l⇩s⇩t B"
by (metis trms⇩s⇩t_append unlabel_append)
lemma trms_proj⇩l⇩s⇩t_append[simp]: "trms_proj⇩l⇩s⇩t l (A@B) = trms_proj⇩l⇩s⇩t l A ∪ trms_proj⇩l⇩s⇩t l B"
by (metis (no_types, lifting) filter_append proj_def trms⇩l⇩s⇩t_append)
lemma trms_proj⇩l⇩s⇩t_subset[simp]:
"trms_proj⇩l⇩s⇩t l A ⊆ trms_proj⇩l⇩s⇩t l (A@B)"
"trms_proj⇩l⇩s⇩t l B ⊆ trms_proj⇩l⇩s⇩t l (A@B)"
using trms_proj⇩l⇩s⇩t_append[of l] by blast+
lemma trms⇩l⇩s⇩t_subset[simp]:
"trms⇩l⇩s⇩t A ⊆ trms⇩l⇩s⇩t (A@B)"
"trms⇩l⇩s⇩t B ⊆ trms⇩l⇩s⇩t (A@B)"
proof (induction A)
case (Cons a A)
obtain l s where *: "a = (l,s)" by moura
{ case 1 thus ?case using Cons * by auto }
{ case 2 thus ?case using Cons * by auto }
qed simp_all
lemma vars⇩l⇩s⇩t_union: "vars⇩l⇩s⇩t A = (⋃l. vars_proj⇩l⇩s⇩t l A)"
proof (induction A)
case (Cons a A)
obtain l s where ls: "a = (l,s)" by moura
have "vars⇩l⇩s⇩t [a] = (⋃l. vars_proj⇩l⇩s⇩t l [a])"
proof -
have *: "vars⇩l⇩s⇩t [a] = vars⇩s⇩t⇩p s" using ls by auto
show ?thesis
proof (cases l)
case (LabelN n)
hence "vars_proj⇩l⇩s⇩t n [a] = vars⇩s⇩t⇩p s" using ls by simp
moreover have "∀m. n ≠ m ⟶ vars_proj⇩l⇩s⇩t m [a] = {}" using ls LabelN by auto
ultimately show ?thesis using * ls by fast
next
case LabelS
hence "∀l. vars_proj⇩l⇩s⇩t l [a] = vars⇩s⇩t⇩p s" using ls by auto
thus ?thesis using * ls by fast
qed
qed
moreover have "∀l. vars_proj⇩l⇩s⇩t l (a#A) = vars_proj⇩l⇩s⇩t l [a] ∪ vars_proj⇩l⇩s⇩t l A"
unfolding unlabel_def proj_def by auto
hence "(⋃l. vars_proj⇩l⇩s⇩t l (a#A)) = (⋃l. vars_proj⇩l⇩s⇩t l [a]) ∪ (⋃l. vars_proj⇩l⇩s⇩t l A)"
using strand_vars_split(1) by auto
ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp
lemma unlabel_Cons_inv:
"unlabel A = b#B ⟹ ∃A'. (∃n. A = (ln n, b)#A') ∨ A = (⋆, b)#A'"
proof -
assume *: "unlabel A = b#B"
then obtain l A' where "A = (l,b)#A'" unfolding unlabel_def by moura
thus "∃A'. (∃l. A = (ln l, b)#A') ∨ A = (⋆, b)#A'" by (metis strand_label.exhaust)
qed
lemma unlabel_snoc_inv:
"unlabel A = B@[b] ⟹ ∃A'. (∃n. A = A'@[(ln n, b)]) ∨ A = A'@[(⋆, b)]"
proof -
assume *: "unlabel A = B@[b]"
then obtain A' l where "A = A'@[(l,b)]"
unfolding unlabel_def by (induct A rule: List.rev_induct) auto
thus "∃A'. (∃n. A = A'@[(ln n, b)]) ∨ A = A'@[(⋆, b)]" by (cases l) auto
qed
lemma proj_idem[simp]: "proj l (proj l A) = proj l A"
unfolding proj_def by auto
lemma proj_ik⇩s⇩t_is_proj_rcv_set:
"ik⇩s⇩t (proj_unl n A) = {t. (ln n, Receive t) ∈ set A ∨ (⋆, Receive t) ∈ set A} "
using ik⇩s⇩t_is_rcv_set unfolding unlabel_def proj_def by force
lemma unlabel_ik⇩s⇩t_is_rcv_set:
"ik⇩s⇩t (unlabel A) = {t | l t. (l, Receive t) ∈ set A}"
using ik⇩s⇩t_is_rcv_set unfolding unlabel_def by force
lemma proj_ik_union_is_unlabel_ik:
"ik⇩s⇩t (unlabel A) = (⋃l. ik⇩s⇩t (proj_unl l A))"
proof
show "(⋃l. ik⇩s⇩t (proj_unl l A)) ⊆ ik⇩s⇩t (unlabel A)"
using unlabel_ik⇩s⇩t_is_rcv_set[of A] proj_ik⇩s⇩t_is_proj_rcv_set[of _ A] by auto
show "ik⇩s⇩t (unlabel A) ⊆ (⋃l. ik⇩s⇩t (proj_unl l A))"
proof
fix t assume "t ∈ ik⇩s⇩t (unlabel A)"
then obtain l where "(l, Receive t) ∈ set A"
using ik⇩s⇩t_is_rcv_set unlabel_mem_has_label[of _ A]
by moura
thus "t ∈ (⋃l. ik⇩s⇩t (proj_unl l A))" using proj_ik⇩s⇩t_is_proj_rcv_set[of _ A] by (cases l) auto
qed
qed
lemma proj_ik_append[simp]:
"ik⇩s⇩t (proj_unl l (A@B)) = ik⇩s⇩t (proj_unl l A) ∪ ik⇩s⇩t (proj_unl l B)"
using proj_append(2)[of l A B] ik_append by auto
lemma proj_ik_append_subst_all:
"ik⇩s⇩t (proj_unl l (A@B)) ⋅⇩s⇩e⇩t I = (ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t I) ∪ (ik⇩s⇩t (proj_unl l B) ⋅⇩s⇩e⇩t I)"
using proj_ik_append[of l] by auto
lemma ik_proj_subset[simp]: "ik⇩s⇩t (proj_unl n A) ⊆ trms_proj⇩l⇩s⇩t n A"
by auto
lemma prefix_proj:
"prefix A B ⟹ prefix (unlabel A) (unlabel B)"
"prefix A B ⟹ prefix (proj n A) (proj n B)"
"prefix A B ⟹ prefix (proj_unl n A) (proj_unl n B)"
unfolding prefix_def unlabel_def proj_def by auto
subsection ‹Lemmata: Well-formedness›
lemma wfvarsoccs⇩s⇩t_proj_union:
"wfvarsoccs⇩s⇩t (unlabel A) = (⋃l. wfvarsoccs⇩s⇩t (proj_unl l A))"
proof (induction A)
case (Cons a A)
obtain l s where ls: "a = (l,s)" by moura
have "wfvarsoccs⇩s⇩t (unlabel [a]) = (⋃l. wfvarsoccs⇩s⇩t (proj_unl l [a]))"
proof -
have *: "wfvarsoccs⇩s⇩t (unlabel [a]) = wfvarsoccs⇩s⇩t⇩p s" using ls by auto
show ?thesis
proof (cases l)
case (LabelN n)
hence "wfvarsoccs⇩s⇩t (proj_unl n [a]) = wfvarsoccs⇩s⇩t⇩p s" using ls by simp
moreover have "∀m. n ≠ m ⟶ wfvarsoccs⇩s⇩t (proj_unl m [a]) = {}" using ls LabelN by auto
ultimately show ?thesis using * ls by fast
next
case LabelS
hence "∀l. wfvarsoccs⇩s⇩t (proj_unl l [a]) = wfvarsoccs⇩s⇩t⇩p s" using ls by auto
thus ?thesis using * ls by fast
qed
qed
moreover have
"wfvarsoccs⇩s⇩t (proj_unl l (a#A)) =
wfvarsoccs⇩s⇩t (proj_unl l [a]) ∪ wfvarsoccs⇩s⇩t (proj_unl l A)"
for l
unfolding unlabel_def proj_def by auto
hence "(⋃l. wfvarsoccs⇩s⇩t (proj_unl l (a#A))) =
(⋃l. wfvarsoccs⇩s⇩t (proj_unl l [a])) ∪ (⋃l. wfvarsoccs⇩s⇩t (proj_unl l A))"
using strand_vars_split(1) by auto
ultimately show ?case using Cons.IH ls strand_vars_split(1) by auto
qed simp
lemma wf_if_wf_proj:
assumes "∀l. wf⇩s⇩t V (proj_unl l A)"
shows "wf⇩s⇩t V (unlabel A)"
using assms
proof (induction A arbitrary: V rule: List.rev_induct)
case (snoc a A)
hence IH: "wf⇩s⇩t V (unlabel A)" using proj_append(2)[of _ A] by auto
obtain b l where b: "a = (ln l, b) ∨ a = (⋆, b)" by (cases a, metis strand_label.exhaust)
hence *: "wf⇩s⇩t V (proj_unl l A@[b])"
by (metis snoc.prems proj_append(2) singleton_lst_proj(1) proj_unl_cons(1,3))
thus ?case using IH b snoc.prems proj_append(2)[of l A "[a]"] unlabel_append[of A "[a]"]
proof (cases b)
case (Receive t)
have "fv t ⊆ wfvarsoccs⇩s⇩t (unlabel A) ∪ V"
proof
fix x assume "x ∈ fv t"
hence "x ∈ V ∪ wfvarsoccs⇩s⇩t (proj_unl l A)" using wf_append_exec[OF *] b Receive by auto
thus "x ∈ wfvarsoccs⇩s⇩t (unlabel A) ∪ V" using wfvarsoccs⇩s⇩t_proj_union[of A] by auto
qed
hence "fv t ⊆ wfrestrictedvars⇩s⇩t (unlabel A) ∪ V"
using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] by blast
hence "wf⇩s⇩t V (unlabel A@[Receive t])" by (rule wf_rcv_append'''[OF IH])
thus ?thesis using b Receive unlabel_append[of A "[a]"] by auto
next
case (Equality ac s t)
have "fv t ⊆ wfvarsoccs⇩s⇩t (unlabel A) ∪ V" when "ac = Assign"
proof
fix x assume "x ∈ fv t"
hence "x ∈ V ∪ wfvarsoccs⇩s⇩t (proj_unl l A)" using wf_append_exec[OF *] b Equality that by auto
thus "x ∈ wfvarsoccs⇩s⇩t (unlabel A) ∪ V" using wfvarsoccs⇩s⇩t_proj_union[of A] by auto
qed
hence "fv t ⊆ wfrestrictedvars⇩l⇩s⇩t A ∪ V" when "ac = Assign"
using vars_snd_rcv_strand_subset2(4)[of "unlabel A"] that by blast
hence "wf⇩s⇩t V (unlabel A@[Equality ac s t])"
by (cases ac) (metis wf_eq_append'''[OF IH], metis wf_eq_check_append''[OF IH])
thus ?thesis using b Equality unlabel_append[of A "[a]"] by auto
qed auto
qed simp
end
Theory Parallel_Compositionality
section ‹Parallel Compositionality of Security Protocols›
text ‹\label{sec:Parallel-Compositionality}›
theory Parallel_Compositionality
imports Typing_Result Labeled_Strands
begin
subsection ‹Definitions: Labeled Typed Model Locale›
locale labeled_typed_model = typed_model arity public Ana Γ
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,'var) term ⇒ (('fun,'var) term list × ('fun,'var) term list)"
and Γ::"('fun,'var) term ⇒ ('fun,'atom::finite) term_type"
+
fixes label_witness1 and label_witness2::"'lbl"
assumes at_least_2_labels: "label_witness1 ≠ label_witness2"
begin
text ‹The Ground Sub-Message Patterns (GSMP)›
definition GSMP::"('fun,'var) terms ⇒ ('fun,'var) terms" where
"GSMP P ≡ {t ∈ SMP P. fv t = {}}"
definition typing_cond where
"typing_cond 𝒜 ≡
wf⇩s⇩t {} 𝒜 ∧
fv⇩s⇩t 𝒜 ∩ bvars⇩s⇩t 𝒜 = {} ∧
tfr⇩s⇩t 𝒜 ∧
wf⇩t⇩r⇩m⇩s (trms⇩s⇩t 𝒜) ∧
Ana_invar_subst (ik⇩s⇩t 𝒜 ∪ assignment_rhs⇩s⇩t 𝒜)"
subsection ‹Definitions: GSMP Disjointedness and Parallel Composability›
definition GSMP_disjoint where
"GSMP_disjoint P1 P2 Secrets ≡ GSMP P1 ∩ GSMP P2 ⊆ Secrets ∪ {m. {} ⊢⇩c m}"
definition declassified⇩l⇩s⇩t where
"declassified⇩l⇩s⇩t (𝒜::('fun,'var,'lbl) labeled_strand) ℐ ≡ {t. (⋆, Receive t) ∈ set 𝒜} ⋅⇩s⇩e⇩t ℐ"
definition par_comp where
"par_comp (𝒜::('fun,'var,'lbl) labeled_strand) (Secrets::('fun,'var) terms) ≡
(∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 𝒜) (trms_proj⇩l⇩s⇩t l2 𝒜) Secrets) ∧
(∀s ∈ Secrets. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ Secrets) ∧
ground Secrets"
definition strand_leaks⇩l⇩s⇩t where
"strand_leaks⇩l⇩s⇩t 𝒜 Sec ℐ ≡ (∃t ∈ Sec - declassified⇩l⇩s⇩t 𝒜 ℐ. ∃l. (ℐ ⊨ ⟨proj_unl l 𝒜@[Send t]⟩))"
subsection ‹Definitions: Homogeneous and Numbered Intruder Deduction Variants›
definition proj_specific where
"proj_specific n t 𝒜 Secrets ≡ t ∈ GSMP (trms_proj⇩l⇩s⇩t n 𝒜) - (Secrets ∪ {m. {} ⊢⇩c m})"
definition heterogeneous⇩l⇩s⇩t where
"heterogeneous⇩l⇩s⇩t t 𝒜 Secrets ≡ (
(∃l1 l2. ∃s1 ∈ subterms t. ∃s2 ∈ subterms t.
l1 ≠ l2 ∧ proj_specific l1 s1 𝒜 Secrets ∧ proj_specific l2 s2 𝒜 Secrets))"
abbreviation homogeneous⇩l⇩s⇩t where
"homogeneous⇩l⇩s⇩t t 𝒜 Secrets ≡ ¬heterogeneous⇩l⇩s⇩t t 𝒜 Secrets"
definition intruder_deduct_hom::
"('fun,'var) terms ⇒ ('fun,'var,'lbl) labeled_strand ⇒ ('fun,'var) terms ⇒ ('fun,'var) term
⇒ bool" ("⟨_;_;_⟩ ⊢⇩h⇩o⇩m _" 50)
where
"⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t ≡ ⟨M; λt. homogeneous⇩l⇩s⇩t t 𝒜 Sec ∧ t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)⟩ ⊢⇩r t"
lemma intruder_deduct_hom_AxiomH[simp]:
assumes "t ∈ M"
shows "⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t"
using intruder_deduct_restricted.AxiomR[of t M] assms
unfolding intruder_deduct_hom_def
by blast
lemma intruder_deduct_hom_ComposeH[simp]:
assumes "length X = arity f" "public f" "⋀x. x ∈ set X ⟹ ⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m x"
and "homogeneous⇩l⇩s⇩t (Fun f X) 𝒜 Sec" "Fun f X ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
shows "⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m Fun f X"
proof -
let ?Q = "λt. homogeneous⇩l⇩s⇩t t 𝒜 Sec ∧ t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
show ?thesis
using intruder_deduct_restricted.ComposeR[of X f M ?Q] assms
unfolding intruder_deduct_hom_def
by blast
qed
lemma intruder_deduct_hom_DecomposeH:
assumes "⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t" "Ana t = (K, T)" "⋀k. k ∈ set K ⟹ ⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m k" "t⇩i ∈ set T"
shows "⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t⇩i"
proof -
let ?Q = "λt. homogeneous⇩l⇩s⇩t t 𝒜 Sec ∧ t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
show ?thesis
using intruder_deduct_restricted.DecomposeR[of M ?Q t] assms
unfolding intruder_deduct_hom_def
by blast
qed
lemma intruder_deduct_hom_induct[consumes 1, case_names AxiomH ComposeH DecomposeH]:
assumes "⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t" "⋀t. t ∈ M ⟹ P M t"
"⋀X f. ⟦length X = arity f; public f;
⋀x. x ∈ set X ⟹ ⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m x;
⋀x. x ∈ set X ⟹ P M x;
homogeneous⇩l⇩s⇩t (Fun f X) 𝒜 Sec;
Fun f X ∈ GSMP (trms⇩l⇩s⇩t 𝒜)
⟧ ⟹ P M (Fun f X)"
"⋀t K T t⇩i. ⟦⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t; P M t; Ana t = (K, T);
⋀k. k ∈ set K ⟹ ⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m k;
⋀k. k ∈ set K ⟹ P M k; t⇩i ∈ set T⟧ ⟹ P M t⇩i"
shows "P M t"
proof -
let ?Q = "λt. homogeneous⇩l⇩s⇩t t 𝒜 Sec ∧ t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
show ?thesis
using intruder_deduct_restricted_induct[of M ?Q t "λM Q t. P M t"] assms
unfolding intruder_deduct_hom_def
by blast
qed
lemma ideduct_hom_mono:
"⟦⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t; M ⊆ M'⟧ ⟹ ⟨M'; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t"
using ideduct_restricted_mono[of M _ t M']
unfolding intruder_deduct_hom_def
by fast
subsection ‹Lemmata: GSMP›
lemma GSMP_disjoint_empty[simp]:
"GSMP_disjoint {} A Sec" "GSMP_disjoint A {} Sec"
unfolding GSMP_disjoint_def GSMP_def by fastforce+
lemma GSMP_mono:
assumes "N ⊆ M"
shows "GSMP N ⊆ GSMP M"
using SMP_mono[OF assms] unfolding GSMP_def by fast
lemma GSMP_SMP_mono:
assumes "SMP N ⊆ SMP M"
shows "GSMP N ⊆ GSMP M"
using assms unfolding GSMP_def by fast
lemma GSMP_subterm:
assumes "t ∈ GSMP M" "t' ⊑ t"
shows "t' ∈ GSMP M"
using SMP.Subterm[of t M t'] ground_subterm[of t t'] assms unfolding GSMP_def by auto
lemma GSMP_subterms: "subterms⇩s⇩e⇩t (GSMP M) = GSMP M"
using GSMP_subterm[of _ M] by blast
lemma GSMP_Ana_key:
assumes "t ∈ GSMP M" "Ana t = (K,T)" "k ∈ set K"
shows "k ∈ GSMP M"
using SMP.Ana[of t M K T k] Ana_keys_fv[of t K T] assms unfolding GSMP_def by auto
lemma GSMP_append[simp]: "GSMP (trms⇩l⇩s⇩t (A@B)) = GSMP (trms⇩l⇩s⇩t A) ∪ GSMP (trms⇩l⇩s⇩t B)"
using SMP_union[of "trms⇩l⇩s⇩t A" "trms⇩l⇩s⇩t B"] trms⇩l⇩s⇩t_append[of A B] unfolding GSMP_def by auto
lemma GSMP_union: "GSMP (A ∪ B) = GSMP A ∪ GSMP B"
using SMP_union[of A B] unfolding GSMP_def by auto
lemma GSMP_Union: "GSMP (trms⇩l⇩s⇩t A) = (⋃l. GSMP (trms_proj⇩l⇩s⇩t l A))"
proof -
define P where "P ≡ (λl. trms_proj⇩l⇩s⇩t l A)"
define Q where "Q ≡ trms⇩l⇩s⇩t A"
have "SMP (⋃l. P l) = (⋃l. SMP (P l))" "Q = (⋃l. P l)"
unfolding P_def Q_def by (metis SMP_Union, metis trms⇩l⇩s⇩t_union)
hence "GSMP Q = (⋃l. GSMP (P l))" unfolding GSMP_def by auto
thus ?thesis unfolding P_def Q_def by metis
qed
lemma in_GSMP_in_proj: "t ∈ GSMP (trms⇩l⇩s⇩t A) ⟹ ∃n. t ∈ GSMP (trms_proj⇩l⇩s⇩t n A)"
using GSMP_Union[of A] by blast
lemma in_proj_in_GSMP: "t ∈ GSMP (trms_proj⇩l⇩s⇩t n A) ⟹ t ∈ GSMP (trms⇩l⇩s⇩t A)"
using GSMP_Union[of A] by blast
lemma GSMP_disjointE:
assumes A: "GSMP_disjoint (trms_proj⇩l⇩s⇩t n A) (trms_proj⇩l⇩s⇩t m A) Sec"
shows "GSMP (trms_proj⇩l⇩s⇩t n A) ∩ GSMP (trms_proj⇩l⇩s⇩t m A) ⊆ Sec ∪ {m. {} ⊢⇩c m}"
using assms unfolding GSMP_disjoint_def by auto
lemma GSMP_disjoint_term:
assumes "GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
shows "t ∉ GSMP (trms_proj⇩l⇩s⇩t l 𝒜) ∨ t ∉ GSMP (trms_proj⇩l⇩s⇩t l' 𝒜) ∨ t ∈ Sec ∨ {} ⊢⇩c t"
using assms unfolding GSMP_disjoint_def by blast
lemma GSMP_wt_subst_subset:
assumes "t ∈ GSMP (M ⋅⇩s⇩e⇩t ℐ)" "wt⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
shows "t ∈ GSMP M"
using SMP_wt_subst_subset[OF _ assms(2,3), of t M] assms(1) unfolding GSMP_def by simp
lemma GSMP_wt_substI:
assumes "t ∈ M" "wt⇩s⇩u⇩b⇩s⇩t I" "wf⇩t⇩r⇩m⇩s (subst_range I)" "interpretation⇩s⇩u⇩b⇩s⇩t I"
shows "t ⋅ I ∈ GSMP M"
proof -
have "t ∈ SMP M" using assms(1) by auto
hence *: "t ⋅ I ∈ SMP M" using SMP.Substitution assms(2,3) wf_trm_subst_range_iff[of I] by simp
moreover have "fv (t ⋅ I) = {}"
using assms(1) interpretation_grounds_all'[OF assms(4)]
by auto
ultimately show ?thesis unfolding GSMP_def by simp
qed
lemma GSMP_disjoint_subset:
assumes "GSMP_disjoint L R S" "L' ⊆ L" "R' ⊆ R"
shows "GSMP_disjoint L' R' S"
using assms(1) SMP_mono[OF assms(2)] SMP_mono[OF assms(3)]
by (auto simp add: GSMP_def GSMP_disjoint_def)
lemma GSMP_disjoint_fst_specific_not_snd_specific:
assumes "GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec" "l ≠ l'"
and "proj_specific l m 𝒜 Sec"
shows "¬proj_specific l' m 𝒜 Sec"
using assms by (fastforce simp add: GSMP_disjoint_def proj_specific_def)
lemma GSMP_disjoint_snd_specific_not_fst_specific:
assumes "GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and "proj_specific l' m 𝒜 Sec"
shows "¬proj_specific l m 𝒜 Sec"
using assms by (auto simp add: GSMP_disjoint_def proj_specific_def)
lemma GSMP_disjoint_intersection_not_specific:
assumes "GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and "t ∈ Sec ∨ {} ⊢⇩c t"
shows "¬proj_specific l t 𝒜 Sec" "¬proj_specific l t 𝒜 Sec"
using assms by (auto simp add: GSMP_disjoint_def proj_specific_def)
subsection ‹Lemmata: Intruder Knowledge and Declassification›
lemma ik_proj_subst_GSMP_subset:
assumes I: "wt⇩s⇩u⇩b⇩s⇩t I" "wf⇩t⇩r⇩m⇩s (subst_range I)" "interpretation⇩s⇩u⇩b⇩s⇩t I"
shows "ik⇩s⇩t (proj_unl n A) ⋅⇩s⇩e⇩t I ⊆ GSMP (trms_proj⇩l⇩s⇩t n A)"
proof
fix t assume "t ∈ ik⇩s⇩t (proj_unl n A) ⋅⇩s⇩e⇩t I"
hence *: "t ∈ trms_proj⇩l⇩s⇩t n A ⋅⇩s⇩e⇩t I" by auto
then obtain s where "s ∈ trms_proj⇩l⇩s⇩t n A" "t = s ⋅ I" by auto
hence "t ∈ SMP (trms_proj⇩l⇩s⇩t n A)" using SMP_I I(1,2) wf_trm_subst_range_iff[of I] by simp
moreover have "fv t = {}"
using * interpretation_grounds_all'[OF I(3)]
by auto
ultimately show "t ∈ GSMP (trms_proj⇩l⇩s⇩t n A)" unfolding GSMP_def by simp
qed
lemma declassified_proj_ik_subset: "declassified⇩l⇩s⇩t A I ⊆ ik⇩s⇩t (proj_unl n A) ⋅⇩s⇩e⇩t I"
proof (induction A)
case (Cons a A) thus ?case
using proj_ik_append[of n "[a]" A] by (auto simp add: declassified⇩l⇩s⇩t_def)
qed (simp add: declassified⇩l⇩s⇩t_def)
lemma declassified_proj_GSMP_subset:
assumes I: "wt⇩s⇩u⇩b⇩s⇩t I" "wf⇩t⇩r⇩m⇩s (subst_range I)" "interpretation⇩s⇩u⇩b⇩s⇩t I"
shows "declassified⇩l⇩s⇩t A I ⊆ GSMP (trms_proj⇩l⇩s⇩t n A)"
by (rule subset_trans[OF declassified_proj_ik_subset ik_proj_subst_GSMP_subset[OF I]])
lemma declassified_subterms_proj_GSMP_subset:
assumes I: "wt⇩s⇩u⇩b⇩s⇩t I" "wf⇩t⇩r⇩m⇩s (subst_range I)" "interpretation⇩s⇩u⇩b⇩s⇩t I"
shows "subterms⇩s⇩e⇩t (declassified⇩l⇩s⇩t A I) ⊆ GSMP (trms_proj⇩l⇩s⇩t n A)"
proof
fix t assume t: "t ∈ subterms⇩s⇩e⇩t (declassified⇩l⇩s⇩t A I)"
then obtain t' where t': "t' ∈ declassified⇩l⇩s⇩t A I" "t ⊑ t'" by moura
hence "t' ∈ GSMP (trms_proj⇩l⇩s⇩t n A)" using declassified_proj_GSMP_subset[OF assms] by blast
thus "t ∈ GSMP (trms_proj⇩l⇩s⇩t n A)"
using SMP.Subterm[of t' "trms_proj⇩l⇩s⇩t n A" t] ground_subterm[OF _ t'(2)] t'(2)
unfolding GSMP_def by fast
qed
lemma declassified_secrets_subset:
assumes A: "∀n m. n ≠ m ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t n A) (trms_proj⇩l⇩s⇩t m A) Sec"
and I: "wt⇩s⇩u⇩b⇩s⇩t I" "wf⇩t⇩r⇩m⇩s (subst_range I)" "interpretation⇩s⇩u⇩b⇩s⇩t I"
shows "declassified⇩l⇩s⇩t A I ⊆ Sec ∪ {m. {} ⊢⇩c m}"
using declassified_proj_GSMP_subset[OF I] A at_least_2_labels
unfolding GSMP_disjoint_def by blast
lemma declassified_subterms_secrets_subset:
assumes A: "∀n m. n ≠ m ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t n A) (trms_proj⇩l⇩s⇩t m A) Sec"
and I: "wt⇩s⇩u⇩b⇩s⇩t I" "wf⇩t⇩r⇩m⇩s (subst_range I)" "interpretation⇩s⇩u⇩b⇩s⇩t I"
shows "subterms⇩s⇩e⇩t (declassified⇩l⇩s⇩t A I) ⊆ Sec ∪ {m. {} ⊢⇩c m}"
using declassified_subterms_proj_GSMP_subset[OF I, of A label_witness1]
declassified_subterms_proj_GSMP_subset[OF I, of A label_witness2]
A at_least_2_labels
unfolding GSMP_disjoint_def by fast
lemma declassified_proj_eq: "declassified⇩l⇩s⇩t A I = declassified⇩l⇩s⇩t (proj n A) I"
unfolding declassified⇩l⇩s⇩t_def proj_def by auto
lemma declassified_append: "declassified⇩l⇩s⇩t (A@B) I = declassified⇩l⇩s⇩t A I ∪ declassified⇩l⇩s⇩t B I"
unfolding declassified⇩l⇩s⇩t_def by auto
lemma declassified_prefix_subset: "prefix A B ⟹ declassified⇩l⇩s⇩t A I ⊆ declassified⇩l⇩s⇩t B I"
using declassified_append unfolding prefix_def by auto
subsection ‹Lemmata: Homogeneous and Heterogeneous Terms›
lemma proj_specific_secrets_anti_mono:
assumes "proj_specific l t 𝒜 Sec" "Sec' ⊆ Sec"
shows "proj_specific l t 𝒜 Sec'"
using assms unfolding proj_specific_def by fast
lemma heterogeneous_secrets_anti_mono:
assumes "heterogeneous⇩l⇩s⇩t t 𝒜 Sec" "Sec' ⊆ Sec"
shows "heterogeneous⇩l⇩s⇩t t 𝒜 Sec'"
using assms proj_specific_secrets_anti_mono unfolding heterogeneous⇩l⇩s⇩t_def by metis
lemma homogeneous_secrets_mono:
assumes "homogeneous⇩l⇩s⇩t t 𝒜 Sec'" "Sec' ⊆ Sec"
shows "homogeneous⇩l⇩s⇩t t 𝒜 Sec"
using assms heterogeneous_secrets_anti_mono by blast
lemma heterogeneous_supterm:
assumes "heterogeneous⇩l⇩s⇩t t 𝒜 Sec" "t ⊑ t'"
shows "heterogeneous⇩l⇩s⇩t t' 𝒜 Sec"
proof -
obtain l1 l2 s1 s2 where *:
"l1 ≠ l2"
"s1 ⊑ t" "proj_specific l1 s1 𝒜 Sec"
"s2 ⊑ t" "proj_specific l2 s2 𝒜 Sec"
using assms(1) unfolding heterogeneous⇩l⇩s⇩t_def by moura
thus ?thesis
using term.order_trans[OF *(2) assms(2)] term.order_trans[OF *(4) assms(2)]
by (auto simp add: heterogeneous⇩l⇩s⇩t_def)
qed
lemma homogeneous_subterm:
assumes "homogeneous⇩l⇩s⇩t t 𝒜 Sec" "t' ⊑ t"
shows "homogeneous⇩l⇩s⇩t t' 𝒜 Sec"
by (metis assms heterogeneous_supterm)
lemma proj_specific_subterm:
assumes "t ⊑ t'" "proj_specific l t' 𝒜 Sec"
shows "proj_specific l t 𝒜 Sec ∨ t ∈ Sec ∨ {} ⊢⇩c t"
using GSMP_subterm[OF _ assms(1)] assms(2) by (auto simp add: proj_specific_def)
lemma heterogeneous_term_is_Fun:
assumes "heterogeneous⇩l⇩s⇩t t A S" shows "∃f T. t = Fun f T"
using assms by (cases t) (auto simp add: GSMP_def heterogeneous⇩l⇩s⇩t_def proj_specific_def)
lemma proj_specific_is_homogeneous:
assumes 𝒜: "∀l l'. l ≠ l' ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and t: "proj_specific l m 𝒜 Sec"
shows "homogeneous⇩l⇩s⇩t m 𝒜 Sec"
proof
assume "heterogeneous⇩l⇩s⇩t m 𝒜 Sec"
then obtain s l' where s: "s ∈ subterms m" "proj_specific l' s 𝒜 Sec" "l ≠ l'"
unfolding heterogeneous⇩l⇩s⇩t_def by moura
hence "s ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)" "s ∈ GSMP (trms_proj⇩l⇩s⇩t l' 𝒜)"
using t by (auto simp add: GSMP_def proj_specific_def)
hence "s ∈ Sec ∨ {} ⊢⇩c s"
using 𝒜 s(3) by (auto simp add: GSMP_disjoint_def)
thus False using s(2) by (auto simp add: proj_specific_def)
qed
lemma deduct_synth_homogeneous:
assumes "{} ⊢⇩c t"
shows "homogeneous⇩l⇩s⇩t t 𝒜 Sec"
proof -
have "∀s ∈ subterms t. {} ⊢⇩c s" using deduct_synth_subterm[OF assms] by auto
thus ?thesis unfolding heterogeneous⇩l⇩s⇩t_def proj_specific_def by auto
qed
lemma GSMP_proj_is_homogeneous:
assumes "∀l l'. l ≠ l' ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l A) (trms_proj⇩l⇩s⇩t l' A) Sec"
and "t ∈ GSMP (trms_proj⇩l⇩s⇩t l A)" "t ∉ Sec"
shows "homogeneous⇩l⇩s⇩t t A Sec"
proof
assume "heterogeneous⇩l⇩s⇩t t A Sec"
then obtain s l' where s: "s ∈ subterms t" "proj_specific l' s A Sec" "l ≠ l'"
unfolding heterogeneous⇩l⇩s⇩t_def by moura
hence "s ∈ GSMP (trms_proj⇩l⇩s⇩t l A)" "s ∈ GSMP (trms_proj⇩l⇩s⇩t l' A)"
using assms by (auto simp add: GSMP_def proj_specific_def)
hence "s ∈ Sec ∨ {} ⊢⇩c s" using assms(1) s(3) by (auto simp add: GSMP_disjoint_def)
thus False using s(2) by (auto simp add: proj_specific_def)
qed
lemma homogeneous_is_not_proj_specific:
assumes "homogeneous⇩l⇩s⇩t m 𝒜 Sec"
shows "∃l::'lbl. ¬proj_specific l m 𝒜 Sec"
proof -
let ?P = "λl s. proj_specific l s 𝒜 Sec"
have "∀l1 l2. ∀s1∈subterms m. ∀s2∈subterms m. (l1 ≠ l2 ⟶ (¬?P l1 s1 ∨ ¬?P l2 s2))"
using assms heterogeneous⇩l⇩s⇩t_def by metis
then obtain l1 l2 where "l1 ≠ l2" "¬?P l1 m ∨ ¬?P l2 m"
by (metis term.order_refl at_least_2_labels)
thus ?thesis by metis
qed
lemma secrets_are_homogeneous:
assumes "∀s ∈ Sec. P s ⟶ (∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ Sec)" "s ∈ Sec" "P s"
shows "homogeneous⇩l⇩s⇩t s 𝒜 Sec"
using assms by (auto simp add: heterogeneous⇩l⇩s⇩t_def proj_specific_def)
lemma GSMP_is_homogeneous:
assumes 𝒜: "∀l l'. l ≠ l' ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and t: "t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)" "t ∉ Sec"
shows "homogeneous⇩l⇩s⇩t t 𝒜 Sec"
proof -
obtain n where n: "t ∈ GSMP (trms_proj⇩l⇩s⇩t n 𝒜)" using in_GSMP_in_proj[OF t(1)] by moura
show ?thesis using GSMP_proj_is_homogeneous[OF 𝒜 n t(2)] by metis
qed
lemma GSMP_intersection_is_homogeneous:
assumes 𝒜: "∀l l'. l ≠ l' ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and t: "t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜) ∩ GSMP (trms_proj⇩l⇩s⇩t l' 𝒜)" "l ≠ l'"
shows "homogeneous⇩l⇩s⇩t t 𝒜 Sec"
proof -
define M where "M ≡ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
define M' where "M' ≡ GSMP (trms_proj⇩l⇩s⇩t l' 𝒜)"
have t_in: "t ∈ M ∩ M'" "t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
using t(1) in_proj_in_GSMP[of t _ 𝒜]
unfolding M_def M'_def by blast+
have "M ∩ M' ⊆ Sec ∪ {m. {} ⊢⇩c m}"
using 𝒜 GSMP_disjointE[of l 𝒜 l' Sec] t(2)
unfolding M_def M'_def by presburger
moreover have "subterms⇩s⇩e⇩t (M ∩ M') = M ∩ M'"
using GSMP_subterms unfolding M_def M'_def by blast
ultimately have *: "subterms⇩s⇩e⇩t (M ∩ M') ⊆ Sec ∪ {m. {} ⊢⇩c m}"
by blast
show ?thesis
proof (cases "t ∈ Sec")
case True thus ?thesis
using * secrets_are_homogeneous[of Sec "λt. t ∈ M ∩ M'", OF _ _ t_in(1)]
by fast
qed (metis GSMP_is_homogeneous[OF 𝒜 t_in(2)])
qed
lemma GSMP_is_homogeneous':
assumes 𝒜: "∀l l'. l ≠ l' ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and t: "t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
"t ∉ Sec - ⋃{GSMP (trms_proj⇩l⇩s⇩t l1 𝒜) ∩ GSMP (trms_proj⇩l⇩s⇩t l2 𝒜) | l1 l2. l1 ≠ l2}"
shows "homogeneous⇩l⇩s⇩t t 𝒜 Sec"
using GSMP_is_homogeneous[OF 𝒜 t(1)] GSMP_intersection_is_homogeneous[OF 𝒜] t(2)
by blast
lemma declassified_secrets_are_homogeneous:
assumes 𝒜: "∀l l'. l ≠ l' ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and ℐ: "wt⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
and s: "s ∈ declassified⇩l⇩s⇩t 𝒜 ℐ"
shows "homogeneous⇩l⇩s⇩t s 𝒜 Sec"
proof -
have s_in: "s ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
using declassified_proj_GSMP_subset[OF ℐ, of 𝒜 label_witness1]
in_proj_in_GSMP[of s label_witness1 𝒜] s
by blast
show ?thesis
proof (cases "s ∈ Sec")
case True thus ?thesis
using declassified_subterms_secrets_subset[OF 𝒜 ℐ]
secrets_are_homogeneous[of Sec "λs. s ∈ declassified⇩l⇩s⇩t 𝒜 ℐ", OF _ _ s]
by fast
qed (metis GSMP_is_homogeneous[OF 𝒜 s_in])
qed
lemma Ana_keys_homogeneous:
assumes 𝒜: "∀l l'. l ≠ l' ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l 𝒜) (trms_proj⇩l⇩s⇩t l' 𝒜) Sec"
and t: "t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
and k: "Ana t = (K,T)" "k ∈ set K"
"k ∉ Sec - ⋃{GSMP (trms_proj⇩l⇩s⇩t l1 𝒜) ∩ GSMP (trms_proj⇩l⇩s⇩t l2 𝒜) | l1 l2. l1 ≠ l2}"
shows "homogeneous⇩l⇩s⇩t k 𝒜 Sec"
proof (cases "k ∈ ⋃{GSMP (trms_proj⇩l⇩s⇩t l1 𝒜) ∩ GSMP (trms_proj⇩l⇩s⇩t l2 𝒜) | l1 l2. l1 ≠ l2}")
case False
hence "k ∉ Sec" using k(3) by fast
moreover have "k ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
using t SMP.Ana[OF _ k(1,2)] Ana_keys_fv[OF k(1)] k(2)
unfolding GSMP_def by auto
ultimately show ?thesis using GSMP_is_homogeneous[OF 𝒜, of k] by metis
qed (use GSMP_intersection_is_homogeneous[OF 𝒜] in blast)
subsection ‹Lemmata: Intruder Deduction Equivalences›
lemma deduct_if_hom_deduct: "⟨M;A;S⟩ ⊢⇩h⇩o⇩m m ⟹ M ⊢ m"
using deduct_if_restricted_deduct unfolding intruder_deduct_hom_def by blast
lemma hom_deduct_if_hom_ik:
assumes "⟨M;A;Sec⟩ ⊢⇩h⇩o⇩m m" "∀m ∈ M. homogeneous⇩l⇩s⇩t m A Sec ∧ m ∈ GSMP (trms⇩l⇩s⇩t A)"
shows "homogeneous⇩l⇩s⇩t m A Sec ∧ m ∈ GSMP (trms⇩l⇩s⇩t A)"
proof -
let ?Q = "λm. homogeneous⇩l⇩s⇩t m A Sec ∧ m ∈ GSMP (trms⇩l⇩s⇩t A)"
have "?Q t'" when "?Q t" "t' ⊑ t" for t t'
using homogeneous_subterm[OF _ that(2)] GSMP_subterm[OF _ that(2)] that(1)
by blast
thus ?thesis
using assms(1) restricted_deduct_if_restricted_ik[OF _ assms(2)]
unfolding intruder_deduct_hom_def
by blast
qed
lemma deduct_hom_if_synth:
assumes hom: "homogeneous⇩l⇩s⇩t m 𝒜 Sec" "m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
and m: "M ⊢⇩c m"
shows "⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m m"
proof -
let ?Q = "λm. homogeneous⇩l⇩s⇩t m 𝒜 Sec ∧ m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
have "?Q t'" when "?Q t" "t' ⊑ t" for t t'
using homogeneous_subterm[OF _ that(2)] GSMP_subterm[OF _ that(2)] that(1)
by blast
thus ?thesis
using assms deduct_restricted_if_synth[of ?Q]
unfolding intruder_deduct_hom_def
by blast
qed
lemma hom_deduct_if_deduct:
assumes 𝒜: "par_comp 𝒜 Sec"
and M: "∀m∈M. homogeneous⇩l⇩s⇩t m 𝒜 Sec ∧ m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
and m: "M ⊢ m" "m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
shows "⟨M; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m m"
proof -
let ?P = "λx. homogeneous⇩l⇩s⇩t x 𝒜 Sec ∧ x ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
have GSMP_hom: "homogeneous⇩l⇩s⇩t t 𝒜 Sec" when "t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)" for t
using 𝒜 GSMP_is_homogeneous[of 𝒜 Sec t]
secrets_are_homogeneous[of Sec "λx. True" t 𝒜] that
unfolding par_comp_def by blast
have P_Ana: "?P k" when "?P t" "Ana t = (K, T)" "k ∈ set K" for t K T k
using GSMP_Ana_key[OF _ that(2,3), of "trms⇩l⇩s⇩t 𝒜"] 𝒜 that GSMP_hom
by presburger
have P_subterm: "?P t'" when "?P t" "t' ⊑ t" for t t'
using GSMP_subterm[of _ "trms⇩l⇩s⇩t 𝒜"] homogeneous_subterm[of _ 𝒜 Sec] that
by blast
have P_m: "?P m"
using GSMP_hom[OF m(2)] m(2)
by metis
show ?thesis
using restricted_deduct_if_deduct'[OF M _ _ m(1) P_m] P_Ana P_subterm
unfolding intruder_deduct_hom_def
by fast
qed
subsection ‹Lemmata: Deduction Reduction of Parallel Composable Constraints›
lemma par_comp_hom_deduct:
assumes 𝒜: "par_comp 𝒜 Sec"
and M: "∀l. ∀m ∈ M l. homogeneous⇩l⇩s⇩t m 𝒜 Sec"
"∀l. M l ⊆ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
"∀l. Discl ⊆ M l"
"Discl ⊆ Sec ∪ {m. {} ⊢⇩c m}"
and Sec: "∀l. ∀s ∈ Sec - Discl. ¬(⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m s)"
and t: "⟨⋃l. M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t"
shows "t ∉ Sec - Discl" (is ?A)
"∀l. t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜) ⟶ ⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t" (is ?B)
proof -
have M': "∀l. ∀m ∈ M l. m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
proof (intro allI ballI)
fix l m show "m ∈ M l ⟹ m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)" using M(2) in_proj_in_GSMP[of m l 𝒜] by blast
qed
show ?A ?B using t
proof (induction t rule: intruder_deduct_hom_induct)
case (AxiomH t)
then obtain lt where t_in_proj_ik: "t ∈ M lt" by moura
show t_not_Sec: "t ∉ Sec - Discl"
proof
assume "t ∈ Sec - Discl"
hence "∀l. ¬(⟨M l;𝒜;Sec⟩ ⊢⇩h⇩o⇩m t)" using Sec by auto
thus False using intruder_deduct_hom_AxiomH[OF t_in_proj_ik] by metis
qed
have 1: "∀l. t ∈ M l ⟶ t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
using M(2,3) AxiomH by auto
have 3: "⋀l1 l2. l1 ≠ l2 ⟹ t ∈ GSMP (trms_proj⇩l⇩s⇩t l1 𝒜) ∩ GSMP (trms_proj⇩l⇩s⇩t l2 𝒜)
⟹ {} ⊢⇩c t ∨ t ∈ Discl"
using 𝒜 t_not_Sec by (auto simp add: par_comp_def GSMP_disjoint_def)
have 4: "homogeneous⇩l⇩s⇩t t 𝒜 Sec" "t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)" using M(1) M' t_in_proj_ik by auto
{ fix l assume "t ∈ Discl"
hence "t ∈ M l" using M(3) by auto
hence "⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t" by auto
} hence 5: "∀l. t ∈ Discl ⟶ ⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t" by metis
show "∀l. t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜) ⟶ ⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t"
by (metis (lifting) Int_iff empty_subsetI
1 3 4 5 t_in_proj_ik
intruder_deduct_hom_AxiomH[of t _ 𝒜 Sec]
deduct_hom_if_synth[of t 𝒜 Sec "{}"]
ideduct_hom_mono[of "{}" 𝒜 Sec t])
next
case (ComposeH T f)
show "∀l. Fun f T ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜) ⟶ ⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m Fun f T"
proof (intro allI impI)
fix l
assume "Fun f T ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
hence "⋀t. t ∈ set T ⟹ t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
using GSMP_subterm[OF _ subtermeqI''] by auto
thus "⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m Fun f T"
using ComposeH.IH(2) intruder_deduct_hom_ComposeH[OF ComposeH.hyps(1,2) _ ComposeH.hyps(4,5)]
by simp
qed
thus "Fun f T ∉ Sec - Discl"
using Sec ComposeH.hyps(5) trms⇩l⇩s⇩t_union[of 𝒜] GSMP_Union[of 𝒜]
by (metis (no_types, lifting) UN_iff)
next
case (DecomposeH t K T t⇩i)
have ti_subt: "t⇩i ⊑ t" using Ana_subterm[OF DecomposeH.hyps(2)] ‹t⇩i ∈ set T› by auto
have t: "homogeneous⇩l⇩s⇩t t 𝒜 Sec" "t ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
using DecomposeH.hyps(1) hom_deduct_if_hom_ik M(1) M'
by auto
have ti: "homogeneous⇩l⇩s⇩t t⇩i 𝒜 Sec" "t⇩i ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
using intruder_deduct_hom_DecomposeH[OF DecomposeH.hyps] hom_deduct_if_hom_ik M(1) M' by auto
{ fix l assume *: "t⇩i ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)" "t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
hence "⋀k. k ∈ set K ⟹ ⟨M l;𝒜;Sec⟩ ⊢⇩h⇩o⇩m k"
using GSMP_Ana_key[OF _ DecomposeH.hyps(2)] DecomposeH.IH(4) by auto
hence "⟨M l;𝒜;Sec⟩ ⊢⇩h⇩o⇩m t⇩i" "t⇩i ∉ Sec - Discl"
using Sec DecomposeH.IH(2) *(2)
intruder_deduct_hom_DecomposeH[OF _ DecomposeH.hyps(2) _ ‹t⇩i ∈ set T›]
by force+
} moreover {
fix l1 l2 assume *: "t⇩i ∈ GSMP (trms_proj⇩l⇩s⇩t l1 𝒜)" "t ∈ GSMP (trms_proj⇩l⇩s⇩t l2 𝒜)" "l1 ≠ l2"
have "GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 𝒜) (trms_proj⇩l⇩s⇩t l2 𝒜) Sec"
using *(3) 𝒜 by (simp add: par_comp_def)
hence "t⇩i ∈ Sec ∪ {m. {} ⊢⇩c m}"
using GSMP_subterm[OF *(2) ti_subt] *(1) by (auto simp add: GSMP_disjoint_def)
moreover have "⋀k. k ∈ set K ⟹ ⟨M l2;𝒜;Sec⟩ ⊢⇩h⇩o⇩m k"
using *(2) GSMP_Ana_key[OF _ DecomposeH.hyps(2)] DecomposeH.IH(4) by auto
ultimately have "t⇩i ∉ Sec - Discl" "{} ⊢⇩c t⇩i ∨ t⇩i ∈ Discl"
using Sec DecomposeH.IH(2) *(2)
intruder_deduct_hom_DecomposeH[OF _ DecomposeH.hyps(2) _ ‹t⇩i ∈ set T›]
by (metis (lifting), metis (no_types, lifting) DiffI Un_iff mem_Collect_eq)
hence "⟨M l1;𝒜;Sec⟩ ⊢⇩h⇩o⇩m t⇩i" "⟨M l2;𝒜;Sec⟩ ⊢⇩h⇩o⇩m t⇩i" "t⇩i ∉ Sec - Discl"
using M(3,4) deduct_hom_if_synth[THEN ideduct_hom_mono] ti
by (meson intruder_deduct_hom_AxiomH empty_subsetI subsetCE)+
} moreover have
"∃l. t⇩i ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
"∃l. t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
using in_GSMP_in_proj[of _ 𝒜] ti(2) t(2) by presburger+
ultimately show
"t⇩i ∉ Sec - Discl"
"∀l. t⇩i ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜) ⟶ ⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t⇩i"
by (metis (no_types, lifting))+
qed
qed
lemma par_comp_deduct_proj:
assumes 𝒜: "par_comp 𝒜 Sec"
and M: "∀l. ∀m∈M l. homogeneous⇩l⇩s⇩t m 𝒜 Sec"
"∀l. M l ⊆ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
"∀l. Discl ⊆ M l"
and t: "(⋃l. M l) ⊢ t" "t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
and Discl: "Discl ⊆ Sec ∪ {m. {} ⊢⇩c m}"
shows "M l ⊢ t ∨ (∃s ∈ Sec - Discl. ∃l. M l ⊢ s)"
using t
proof (induction t rule: intruder_deduct_induct)
case (Axiom t)
then obtain l' where t_in_ik_proj: "t ∈ M l'" by moura
show ?case
proof (cases "t ∈ Sec - Discl ∨ {} ⊢⇩c t")
case True
note T = True
show ?thesis
proof (cases "t ∈ Sec - Discl")
case True thus ?thesis using intruder_deduct.Axiom[OF t_in_ik_proj] by metis
next
case False thus ?thesis using T ideduct_mono[of "{}" t] by auto
qed
next
case False
hence "t ∉ Sec - Discl" "¬{} ⊢⇩c t" "t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)" using Axiom by auto
hence "(∀l'. l ≠ l' ⟶ t ∉ GSMP (trms_proj⇩l⇩s⇩t l' 𝒜)) ∨ t ∈ Discl"
using 𝒜 unfolding GSMP_disjoint_def par_comp_def by auto
hence "(∀l'. l ≠ l' ⟶ t ∉ GSMP (trms_proj⇩l⇩s⇩t l' 𝒜)) ∨ t ∈ M l ∨ {} ⊢⇩c t" using M by auto
thus ?thesis using Axiom deduct_if_synth[THEN ideduct_mono] t_in_ik_proj
by (metis (no_types, lifting) False M(2) intruder_deduct.Axiom subsetCE)
qed
next
case (Compose T f)
hence "Fun f T ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)" using Compose.prems by auto
hence "⋀t. t ∈ set T ⟹ t ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)" unfolding GSMP_def by auto
hence IH: "⋀t. t ∈ set T ⟹ M l ⊢ t ∨ (∃s ∈ Sec - Discl. ∃l. M l ⊢ s)"
using Compose.IH by auto
show ?case
proof (cases "∀t ∈ set T. M l ⊢ t")
case True thus ?thesis by (metis intruder_deduct.Compose[OF Compose.hyps(1,2)])
qed (metis IH)
next
case (Decompose t K T t⇩i)
have hom_ik: "∀l. ∀m∈M l. homogeneous⇩l⇩s⇩t m 𝒜 Sec ∧ m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
proof (intro allI ballI conjI)
fix l m assume m: "m ∈ M l"
thus "homogeneous⇩l⇩s⇩t m 𝒜 Sec" using M(1) by simp
show "m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)" using in_proj_in_GSMP[of m l 𝒜] M(2) m by blast
qed
have par_comp_unfold:
"∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 𝒜) (trms_proj⇩l⇩s⇩t l2 𝒜) Sec"
using 𝒜 by (auto simp add: par_comp_def)
note ti_GSMP = in_proj_in_GSMP[OF Decompose.prems(1)]
have "⟨⋃l. M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t⇩i"
using intruder_deduct.Decompose[OF Decompose.hyps]
hom_deduct_if_deduct[OF 𝒜, of "⋃l. M l"] hom_ik ti_GSMP
by blast
hence "(⟨M l; 𝒜; Sec⟩ ⊢⇩h⇩o⇩m t⇩i) ∨ (∃s ∈ Sec-Discl. ∃l. ⟨M l;𝒜;Sec⟩ ⊢⇩h⇩o⇩m s)"
using par_comp_hom_deduct(2)[OF 𝒜 M Discl(1)] Decompose.prems(1)
by blast
thus ?case using deduct_if_hom_deduct[of _ 𝒜 Sec] by auto
qed
subsection ‹Theorem: Parallel Compositionality for Labeled Constraints›
lemma par_comp_prefix: assumes "par_comp (A@B) M" shows "par_comp A M"
proof -
let ?L = "λl. trms_proj⇩l⇩s⇩t l A ∪ trms_proj⇩l⇩s⇩t l B"
have "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (?L l1) (?L l2) M"
using assms unfolding par_comp_def
by (metis trms⇩s⇩t_append proj_append(2) unlabel_append)
hence "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 A) (trms_proj⇩l⇩s⇩t l2 A) M"
using SMP_union by (auto simp add: GSMP_def GSMP_disjoint_def)
thus ?thesis using assms unfolding par_comp_def by blast
qed
theorem par_comp_constr_typed:
assumes 𝒜: "par_comp 𝒜 Sec"
and ℐ: "ℐ ⊨ ⟨unlabel 𝒜⟩" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "wt⇩s⇩u⇩b⇩s⇩t ℐ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ)"
shows "(∀l. (ℐ ⊨ ⟨proj_unl l 𝒜⟩)) ∨ (∃𝒜'. prefix 𝒜' 𝒜 ∧ (strand_leaks⇩l⇩s⇩t 𝒜' Sec ℐ))"
proof -
let ?L = "λ𝒜'. ∃t ∈ Sec - declassified⇩l⇩s⇩t 𝒜' ℐ. ∃l. ⟦{}; proj_unl l 𝒜'@[Send t]⟧⇩d ℐ"
have "⟦{}; unlabel 𝒜⟧⇩d ℐ" using ℐ by (simp add: constr_sem_d_def)
with 𝒜 have "(∀l. ⟦{}; proj_unl l 𝒜⟧⇩d ℐ) ∨ (∃𝒜'. prefix 𝒜' 𝒜 ∧ ?L 𝒜')"
proof (induction "unlabel 𝒜" arbitrary: 𝒜 rule: List.rev_induct)
case Nil
hence "𝒜 = []" using unlabel_nil_only_if_nil by simp
thus ?case by auto
next
case (snoc b B 𝒜)
hence disj: "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 𝒜) (trms_proj⇩l⇩s⇩t l2 𝒜) Sec"
by (auto simp add: par_comp_def)
obtain a A n where a: "𝒜 = A@[a]" "a = (ln n, b) ∨ a = (⋆, b)"
using unlabel_snoc_inv[OF snoc.hyps(2)[symmetric]] by moura
hence A: "𝒜 = A@[(ln n, b)] ∨ 𝒜 = A@[(⋆, b)]" by metis
have 1: "B = unlabel A" using a snoc.hyps(2) unlabel_append[of A "[a]"] by auto
have 2: "par_comp A Sec" using par_comp_prefix snoc.prems(1) a by metis
have 3: "⟦{}; unlabel A⟧⇩d ℐ" by (metis 1 snoc.prems(2) snoc.hyps(2) strand_sem_split(3))
have IH: "(∀l. ⟦{}; proj_unl l A⟧⇩d ℐ) ∨ (∃𝒜'. prefix 𝒜' A ∧ ?L 𝒜')"
by (rule snoc.hyps(1)[OF 1 2 3])
show ?case
proof (cases "∀l. ⟦{}; proj_unl l A⟧⇩d ℐ")
case False
then obtain 𝒜' where 𝒜': "prefix 𝒜' A" "?L 𝒜'" by (metis IH)
hence "prefix 𝒜' (A@[a])" using a prefix_prefix[of _ A "[a]"] by simp
thus ?thesis using 𝒜'(2) a by auto
next
case True
note IH' = True
show ?thesis
proof (cases b)
case (Send t)
hence "ik⇩s⇩t (unlabel A) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ"
using a ‹⟦{}; unlabel 𝒜⟧⇩d ℐ› strand_sem_split(2)[of "{}" "unlabel A" "unlabel [a]" ℐ]
unlabel_append[of A "[a]"]
by auto
hence *: "(⋃l. (ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ)) ⊢ t ⋅ ℐ"
using proj_ik_union_is_unlabel_ik image_UN by metis
have "ik⇩s⇩t (proj_unl l 𝒜) = ik⇩s⇩t (proj_unl l A)" for l
using Send A
by (metis append_Nil2 ik⇩s⇩t.simps(3) proj_unl_cons(3) proj_nil(2)
singleton_lst_proj(1,2) proj_ik_append)
hence **: "ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊆ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)" for l
using ik_proj_subst_GSMP_subset[OF ℐ(3,4,2), of _ 𝒜]
by auto
note Discl =
declassified_proj_ik_subset[of A ℐ]
declassified_proj_GSMP_subset[OF ℐ(3,4,2), of A]
declassified_secrets_subset[OF disj ℐ(3,4,2)]
declassified_append[of A "[a]" ℐ]
have Sec: "ground Sec"
using 𝒜 by (auto simp add: par_comp_def)
have "∀m∈ik⇩s⇩t (proj_unl l 𝒜) ⋅⇩s⇩e⇩t ℐ. homogeneous⇩l⇩s⇩t m 𝒜 Sec ∨ m ∈ Sec-declassified⇩l⇩s⇩t A ℐ"
"∀m∈ik⇩s⇩t (proj_unl l 𝒜) ⋅⇩s⇩e⇩t ℐ. m ∈ GSMP (trms⇩l⇩s⇩t 𝒜)"
"ik⇩s⇩t (proj_unl l 𝒜) ⋅⇩s⇩e⇩t ℐ ⊆ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
for l
using declassified_secrets_are_homogeneous[OF disj ℐ(3,4,2)]
GSMP_proj_is_homogeneous[OF disj]
ik_proj_subst_GSMP_subset[OF ℐ(3,4,2), of _ 𝒜]
apply (metis (no_types, lifting) Diff_iff Discl(4) UnCI a(1) subsetCE)
using ik_proj_subst_GSMP_subset[OF ℐ(3,4,2), of _ 𝒜]
GSMP_Union[of 𝒜]
by auto
moreover have "ik⇩s⇩t (proj_unl l [a]) = {}" for l
using Send proj_ik⇩s⇩t_is_proj_rcv_set[of _ "[a]"] a(2) by auto
ultimately have M:
"∀l. ∀m∈ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ. homogeneous⇩l⇩s⇩t m 𝒜 Sec ∨ m ∈ Sec-declassified⇩l⇩s⇩t A ℐ"
"∀l. ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊆ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)"
using a(1) proj_ik_append[of _ A "[a]"] by auto
have prefix_A: "prefix A 𝒜" using A by auto
have "s ⋅ ℐ = s"
when "s ∈ Sec" for s
using that Sec by auto
hence leakage_case: "⟦{}; proj_unl l A@[Send s]⟧⇩d ℐ"
when "s ∈ Sec - declassified⇩l⇩s⇩t A ℐ" "ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊢ s" for l s
using that strand_sem_append(2) IH' by auto
have proj_deduct_case_n:
"∀m. m ≠ n ⟶ ⟦{}; proj_unl m (A@[a])⟧⇩d ℐ"
"ik⇩s⇩t (proj_unl n A) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ ⟹ ⟦{}; proj_unl n (A@[a])⟧⇩d ℐ"
when "a = (ln n, Send t)"
using that IH' proj_append(2)[of _ A]
by auto
have proj_deduct_case_star:
"⟦{}; proj_unl l (A@[a])⟧⇩d ℐ"
when "a = (⋆, Send t)" "ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ" for l
using that IH' proj_append(2)[of _ A]
by auto
show ?thesis
proof (cases "∃l. ∃m ∈ ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ. m ∈ Sec - declassified⇩l⇩s⇩t A ℐ")
case True
then obtain l s where ls: "s ∈ Sec - declassified⇩l⇩s⇩t A ℐ" "ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊢ s"
using intruder_deduct.Axiom by metis
thus ?thesis using leakage_case prefix_A by blast
next
case False
hence M': "∀l. ∀m∈ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ. homogeneous⇩l⇩s⇩t m 𝒜 Sec" using M(1) by blast
note deduct_proj_lemma =
par_comp_deduct_proj[OF snoc.prems(1) M' M(2) _ *, of "declassified⇩l⇩s⇩t A ℐ" n]
from a(2) show ?thesis
proof
assume "a = (ln n, b)"
hence "a = (ln n, Send t)" "t ⋅ ℐ ∈ GSMP (trms_proj⇩l⇩s⇩t n 𝒜)"
using Send a(1) trms_proj⇩l⇩s⇩t_append[of n A "[a]"]
GSMP_wt_substI[OF _ ℐ(3,4,2)]
by (metis, force)
hence
"a = (ln n, Send t)"
"∀m. m ≠ n ⟶ ⟦{}; proj_unl m (A@[a])⟧⇩d ℐ"
"ik⇩s⇩t (proj_unl n A) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ ⟹ ⟦{}; proj_unl n (A@[a])⟧⇩d ℐ"
"t ⋅ ℐ ∈ GSMP (trms_proj⇩l⇩s⇩t n 𝒜)"
using proj_deduct_case_n
by auto
hence "(∀l. ⟦{}; proj_unl l 𝒜⟧⇩d ℐ) ∨
(∃s ∈ Sec-declassified⇩l⇩s⇩t A ℐ. ∃l. ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊢ s)"
using deduct_proj_lemma A a Discl
by fast
thus ?thesis using leakage_case prefix_A by metis
next
assume "a = (⋆, b)"
hence ***: "a = (⋆, Send t)" "t ⋅ ℐ ∈ GSMP (trms_proj⇩l⇩s⇩t l 𝒜)" for l
using Send a(1) GSMP_wt_substI[OF _ ℐ(3,4,2)]
by (metis, force)
hence "t ⋅ ℐ ∈ Sec - declassified⇩l⇩s⇩t A ℐ ∨
t ⋅ ℐ ∈ declassified⇩l⇩s⇩t A ℐ ∨
t ⋅ ℐ ∈ {m. {} ⊢⇩c m}"
using snoc.prems(1) a(1) at_least_2_labels
unfolding par_comp_def GSMP_disjoint_def
by blast
thus ?thesis
proof (elim disjE)
assume "t ⋅ ℐ ∈ Sec - declassified⇩l⇩s⇩t A ℐ"
hence "∃s ∈ Sec - declassified⇩l⇩s⇩t A ℐ. ∃l. ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊢ s"
using deduct_proj_lemma ***(2) A a Discl
by blast
thus ?thesis using prefix_A leakage_case by blast
next
assume "t ⋅ ℐ ∈ declassified⇩l⇩s⇩t A ℐ"
hence "ik⇩s⇩t (proj_unl l A) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ" for l
using intruder_deduct.Axiom Discl(1) by blast
thus ?thesis using proj_deduct_case_star[OF ***(1)] a(1) by fast
next
assume "t ⋅ ℐ ∈ {m. {} ⊢⇩c m}"
hence "M ⊢ t ⋅ ℐ" for M using ideduct_mono[OF deduct_if_synth] by blast
thus ?thesis using IH' a(1) ***(1) by fastforce
qed
qed
qed
next
case (Receive t)
hence "⟦{}; proj_unl l 𝒜⟧⇩d ℐ" for l
using IH' a proj_append(2)[of l A "[a]"]
unfolding unlabel_def proj_def by auto
thus ?thesis by metis
next
case (Equality ac t t')
hence *: "⟦M; [Equality ac t t']⟧⇩d ℐ" for M
using a ‹⟦{}; unlabel 𝒜⟧⇩d ℐ› unlabel_append[of A "[a]"]
by auto
show ?thesis
using a proj_append(2)[of _ A "[a]"] Equality
strand_sem_append(2)[OF _ *] IH'
unfolding unlabel_def proj_def by auto
next
case (Inequality X F)
hence *: "⟦M; [Inequality X F]⟧⇩d ℐ" for M
using a ‹⟦{}; unlabel 𝒜⟧⇩d ℐ› unlabel_append[of A "[a]"]
by auto
show ?thesis
using a proj_append(2)[of _ A "[a]"] Inequality
strand_sem_append(2)[OF _ *] IH'
unfolding unlabel_def proj_def by auto
qed
qed
qed
thus ?thesis using ℐ(1) unfolding strand_leaks⇩l⇩s⇩t_def by (simp add: constr_sem_d_def)
qed
theorem par_comp_constr:
assumes 𝒜: "par_comp 𝒜 Sec" "typing_cond (unlabel 𝒜)"
and ℐ: "ℐ ⊨ ⟨unlabel 𝒜⟩" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "∃ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ∧ (ℐ⇩τ ⊨ ⟨unlabel 𝒜⟩) ∧
((∀l. (ℐ⇩τ ⊨ ⟨proj_unl l 𝒜⟩)) ∨ (∃𝒜'. prefix 𝒜' 𝒜 ∧ (strand_leaks⇩l⇩s⇩t 𝒜' Sec ℐ⇩τ)))"
proof -
from 𝒜(2) have *:
"wf⇩s⇩t {} (unlabel 𝒜)"
"fv⇩s⇩t (unlabel 𝒜) ∩ bvars⇩s⇩t (unlabel 𝒜) = {}"
"tfr⇩s⇩t (unlabel 𝒜)"
"wf⇩t⇩r⇩m⇩s (trms⇩s⇩t (unlabel 𝒜))"
"Ana_invar_subst (ik⇩s⇩t (unlabel 𝒜) ∪ assignment_rhs⇩s⇩t (unlabel 𝒜))"
unfolding typing_cond_def tfr⇩s⇩t_def by metis+
obtain ℐ⇩τ where ℐ⇩τ: "ℐ⇩τ ⊨ ⟨unlabel 𝒜⟩" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
using wt_attack_if_tfr_attack_d[OF * ℐ(2,1)] by metis
show ?thesis using par_comp_constr_typed[OF 𝒜(1) ℐ⇩τ] ℐ⇩τ by auto
qed
subsection ‹Theorem: Parallel Compositionality for Labeled Protocols›
subsubsection ‹Definitions: Labeled Protocols›
text ‹
We state our result on the level of protocol traces (i.e., the constraints reachable in a
symbolic execution of the actual protocol). Hence, we do not need to convert protocol strands
to intruder constraints in the following well-formedness definitions.
›
definition wf⇩l⇩s⇩t⇩s::"('fun,'var,'lbl) labeled_strand set ⇒ bool" where
"wf⇩l⇩s⇩t⇩s 𝒮 ≡ (∀𝒜 ∈ 𝒮. wf⇩l⇩s⇩t {} 𝒜) ∧ (∀𝒜 ∈ 𝒮. ∀𝒜' ∈ 𝒮. fv⇩l⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩t 𝒜' = {})"
definition wf⇩l⇩s⇩t⇩s'::"('fun,'var,'lbl) labeled_strand set ⇒ ('fun,'var,'lbl) labeled_strand ⇒ bool"
where
"wf⇩l⇩s⇩t⇩s' 𝒮 𝒜 ≡ (∀𝒜' ∈ 𝒮. wf⇩s⇩t (wfrestrictedvars⇩l⇩s⇩t 𝒜) (unlabel 𝒜')) ∧
(∀𝒜' ∈ 𝒮. ∀𝒜'' ∈ 𝒮. fv⇩l⇩s⇩t 𝒜' ∩ bvars⇩l⇩s⇩t 𝒜'' = {}) ∧
(∀𝒜' ∈ 𝒮. fv⇩l⇩s⇩t 𝒜' ∩ bvars⇩l⇩s⇩t 𝒜 = {}) ∧
(∀𝒜' ∈ 𝒮. fv⇩l⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩t 𝒜' = {})"
definition typing_cond_prot where
"typing_cond_prot 𝒫 ≡
wf⇩l⇩s⇩t⇩s 𝒫 ∧
tfr⇩s⇩e⇩t (⋃(trms⇩l⇩s⇩t ` 𝒫)) ∧
wf⇩t⇩r⇩m⇩s (⋃(trms⇩l⇩s⇩t ` 𝒫)) ∧
(∀𝒜 ∈ 𝒫. list_all tfr⇩s⇩t⇩p (unlabel 𝒜)) ∧
Ana_invar_subst (⋃(ik⇩s⇩t ` unlabel ` 𝒫) ∪ ⋃(assignment_rhs⇩s⇩t ` unlabel ` 𝒫))"
definition par_comp_prot where
"par_comp_prot 𝒫 Sec ≡
(∀l1 l2. l1 ≠ l2 ⟶
GSMP_disjoint (⋃𝒜 ∈ 𝒫. trms_proj⇩l⇩s⇩t l1 𝒜) (⋃𝒜 ∈ 𝒫. trms_proj⇩l⇩s⇩t l2 𝒜) Sec) ∧
ground Sec ∧ (∀s ∈ Sec. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ Sec) ∧
typing_cond_prot 𝒫"
subsubsection ‹Lemmata: Labeled Protocols›
lemma wf⇩l⇩s⇩t⇩s_eqs_wf⇩l⇩s⇩t⇩s'[simp]: "wf⇩l⇩s⇩t⇩s S = wf⇩l⇩s⇩t⇩s' S []"
unfolding wf⇩l⇩s⇩t⇩s_def wf⇩l⇩s⇩t⇩s'_def unlabel_def by auto
lemma par_comp_prot_impl_par_comp:
assumes "par_comp_prot 𝒫 Sec" "𝒜 ∈ 𝒫"
shows "par_comp 𝒜 Sec"
proof -
have *: "∀l1 l2. l1 ≠ l2 ⟶
GSMP_disjoint (⋃𝒜 ∈ 𝒫. trms_proj⇩l⇩s⇩t l1 𝒜) (⋃𝒜 ∈ 𝒫. trms_proj⇩l⇩s⇩t l2 𝒜) Sec"
using assms(1) unfolding par_comp_prot_def by metis
{ fix l1 l2::'lbl assume **: "l1 ≠ l2"
hence ***: "GSMP_disjoint (⋃𝒜 ∈ 𝒫. trms_proj⇩l⇩s⇩t l1 𝒜) (⋃𝒜 ∈ 𝒫. trms_proj⇩l⇩s⇩t l2 𝒜) Sec"
using * by auto
have "GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 𝒜) (trms_proj⇩l⇩s⇩t l2 𝒜) Sec"
using GSMP_disjoint_subset[OF ***] assms(2) by auto
} hence "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 𝒜) (trms_proj⇩l⇩s⇩t l2 𝒜) Sec" by metis
thus ?thesis using assms unfolding par_comp_prot_def par_comp_def by metis
qed
lemma typing_cond_prot_impl_typing_cond:
assumes "typing_cond_prot 𝒫" "𝒜 ∈ 𝒫"
shows "typing_cond (unlabel 𝒜)"
proof -
have 1: "wf⇩s⇩t {} (unlabel 𝒜)" "fv⇩l⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩t 𝒜 = {}"
using assms unfolding typing_cond_prot_def wf⇩l⇩s⇩t⇩s_def by auto
have "tfr⇩s⇩e⇩t (⋃(trms⇩l⇩s⇩t ` 𝒫))"
"wf⇩t⇩r⇩m⇩s (⋃(trms⇩l⇩s⇩t ` 𝒫))"
"trms⇩l⇩s⇩t 𝒜 ⊆ ⋃(trms⇩l⇩s⇩t ` 𝒫)"
"SMP (trms⇩l⇩s⇩t 𝒜) - Var`𝒱 ⊆ SMP (⋃(trms⇩l⇩s⇩t ` 𝒫)) - Var`𝒱"
using assms SMP_mono[of "trms⇩l⇩s⇩t 𝒜" "⋃(trms⇩l⇩s⇩t ` 𝒫)"]
unfolding typing_cond_prot_def
by (metis, metis, auto)
hence 2: "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩t 𝒜)" and 3: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩t 𝒜)"
unfolding tfr⇩s⇩e⇩t_def by (meson subsetD)+
have 4: "list_all tfr⇩s⇩t⇩p (unlabel 𝒜)" using assms unfolding typing_cond_prot_def by auto
have "subterms⇩s⇩e⇩t (ik⇩s⇩t (unlabel 𝒜) ∪ assignment_rhs⇩s⇩t (unlabel 𝒜)) ⊆
subterms⇩s⇩e⇩t (⋃(ik⇩s⇩t ` unlabel ` 𝒫) ∪ ⋃(assignment_rhs⇩s⇩t ` unlabel ` 𝒫))"
using assms(2) by auto
hence 5: "Ana_invar_subst (ik⇩s⇩t (unlabel 𝒜) ∪ assignment_rhs⇩s⇩t (unlabel 𝒜))"
using assms SMP_mono unfolding typing_cond_prot_def Ana_invar_subst_def by (meson subsetD)
show ?thesis using 1 2 3 4 5 unfolding typing_cond_def tfr⇩s⇩t_def by blast
qed
subsubsection ‹Theorem: Parallel Compositionality for Labeled Protocols›
definition component_prot where
"component_prot n P ≡ (∀l ∈ P. ∀s ∈ set l. is_LabelN n s ∨ is_LabelS s)"
definition composed_prot where
"composed_prot 𝒫⇩i ≡ {𝒜. ∀n. proj n 𝒜 ∈ 𝒫⇩i n}"
definition component_secure_prot where
"component_secure_prot n P Sec attack ≡ (∀𝒜 ∈ P. suffix [(ln n, Send (Fun attack []))] 𝒜 ⟶
(∀ℐ⇩τ. (interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)) ⟶
¬(ℐ⇩τ ⊨ ⟨proj_unl n 𝒜⟩) ∧
(∀𝒜'. prefix 𝒜' 𝒜 ⟶
(∀t ∈ Sec-declassified⇩l⇩s⇩t 𝒜' ℐ⇩τ. ¬(ℐ⇩τ ⊨ ⟨proj_unl n 𝒜'@[Send t]⟩)))))"
definition component_leaks where
"component_leaks n 𝒜 Sec ≡ (∃𝒜' ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ∧
prefix 𝒜' 𝒜 ∧ (∃t ∈ Sec - declassified⇩l⇩s⇩t 𝒜' ℐ⇩τ. (ℐ⇩τ ⊨ ⟨proj_unl n 𝒜'@[Send t]⟩)))"
definition unsat where
"unsat 𝒜 ≡ (∀ℐ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ ⟶ ¬(ℐ ⊨ ⟨unlabel 𝒜⟩))"
theorem par_comp_constr_prot:
assumes P: "P = composed_prot Pi" "par_comp_prot P Sec" "∀n. component_prot n (Pi n)"
and left_secure: "component_secure_prot n (Pi n) Sec attack"
shows "∀𝒜 ∈ P. suffix [(ln n, Send (Fun attack []))] 𝒜 ⟶
unsat 𝒜 ∨ (∃m. n ≠ m ∧ component_leaks m 𝒜 Sec)"
proof -
{ fix 𝒜 𝒜' assume 𝒜: "𝒜 = 𝒜'@[(ln n, Send (Fun attack []))]" "𝒜 ∈ P"
let ?P = "∃𝒜' ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ∧ prefix 𝒜' 𝒜 ∧
(∃t ∈ Sec - declassified⇩l⇩s⇩t 𝒜' ℐ⇩τ. ∃m. n ≠ m ∧ (ℐ⇩τ ⊨ ⟨proj_unl m 𝒜'@[Send t]⟩))"
have tcp: "typing_cond_prot P" using P(2) unfolding par_comp_prot_def by simp
have par_comp: "par_comp 𝒜 Sec" "typing_cond (unlabel 𝒜)"
using par_comp_prot_impl_par_comp[OF P(2) 𝒜(2)]
typing_cond_prot_impl_typing_cond[OF tcp 𝒜(2)]
by metis+
have "unlabel (proj n 𝒜) = proj_unl n 𝒜" "proj_unl n 𝒜 = proj_unl n (proj n 𝒜)"
"⋀A. A ∈ Pi n ⟹ proj n A = A"
"proj n 𝒜 = (proj n 𝒜')@[(ln n, Send (Fun attack []))]"
using P(1,3) 𝒜 by (auto simp add: proj_def unlabel_def component_prot_def composed_prot_def)
moreover have "proj n 𝒜 ∈ Pi n"
using P(1) 𝒜 unfolding composed_prot_def by blast
moreover {
fix A assume "prefix A 𝒜"
hence *: "prefix (proj n A) (proj n 𝒜)" unfolding proj_def prefix_def by force
hence "proj_unl n A = proj_unl n (proj n A)"
"∀I. declassified⇩l⇩s⇩t A I = declassified⇩l⇩s⇩t (proj n A) I"
unfolding proj_def declassified⇩l⇩s⇩t_def by auto
hence "∃B. prefix B (proj n 𝒜) ∧ proj_unl n A = proj_unl n B ∧
(∀I. declassified⇩l⇩s⇩t A I = declassified⇩l⇩s⇩t B I)"
using * by metis
}
ultimately have *:
"∀ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ⟶
¬(ℐ⇩τ ⊨ ⟨proj_unl n 𝒜⟩) ∧ (∀𝒜'. prefix 𝒜' 𝒜 ⟶
(∀t ∈ Sec - declassified⇩l⇩s⇩t 𝒜' ℐ⇩τ. ¬(ℐ⇩τ ⊨ ⟨proj_unl n 𝒜'@[Send t]⟩)))"
using left_secure unfolding component_secure_prot_def composed_prot_def suffix_def by metis
{ fix ℐ assume ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "ℐ ⊨ ⟨unlabel 𝒜⟩"
obtain ℐ⇩τ where ℐ⇩τ:
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
"∃𝒜'. prefix 𝒜' 𝒜 ∧ (strand_leaks⇩l⇩s⇩t 𝒜' Sec ℐ⇩τ)"
using par_comp_constr[OF par_comp ℐ(2,1)] * by moura
hence "∃𝒜'. prefix 𝒜' 𝒜 ∧ (∃t ∈ Sec - declassified⇩l⇩s⇩t 𝒜' ℐ⇩τ. ∃m.
n ≠ m ∧ (ℐ⇩τ ⊨ ⟨proj_unl m 𝒜'@[Send t]⟩))"
using ℐ⇩τ(4) * unfolding strand_leaks⇩l⇩s⇩t_def by metis
hence ?P using ℐ⇩τ(1,2,3) by auto
} hence "unsat 𝒜 ∨ (∃m. n ≠ m ∧ component_leaks m 𝒜 Sec)"
by (metis unsat_def component_leaks_def)
} thus ?thesis unfolding suffix_def by metis
qed
end
subsection ‹Automated GSMP Disjointness›
locale labeled_typed_model' = typed_model' arity public Ana Γ +
labeled_typed_model arity public Ana Γ label_witness1 label_witness2
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
⇒ (('fun,(('fun,'atom) term_type × nat)) term list
× ('fun,(('fun,'atom) term_type × nat)) term list)"
and Γ::"('fun,(('fun,'atom) term_type × nat)) term ⇒ ('fun,'atom) term_type"
and label_witness1 label_witness2::'lbl
begin
lemma GSMP_disjointI:
fixes A' A B B'::"('fun, ('fun, 'atom) term × nat) term list"
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and "δ ≡ var_rename (max_var_set (fv⇩s⇩e⇩t (set A)))"
assumes A'_wf: "list_all (wf⇩t⇩r⇩m' arity) A'"
and B'_wf: "list_all (wf⇩t⇩r⇩m' arity) B'"
and A_inst: "has_all_wt_instances_of Γ (set A') (set A)"
and B_inst: "has_all_wt_instances_of Γ (set B') (set (B ⋅⇩l⇩i⇩s⇩t δ))"
and A_SMP_repr: "finite_SMP_representation arity Ana Γ A"
and B_SMP_repr: "finite_SMP_representation arity Ana Γ (B ⋅⇩l⇩i⇩s⇩t δ)"
and AB_trms_disj:
"∀t ∈ set A. ∀s ∈ set (B ⋅⇩l⇩i⇩s⇩t δ). Γ t = Γ s ∧ mgu t s ≠ None ⟶
(intruder_synth' public arity {} t ∧ intruder_synth' public arity {} s) ∨
((∃u ∈ Sec. is_wt_instance_of_cond Γ t u) ∧ (∃u ∈ Sec. is_wt_instance_of_cond Γ s u))"
and Sec_wf: "wf⇩t⇩r⇩m⇩s Sec"
shows "GSMP_disjoint (set A') (set B') ((f Sec) - {m. {} ⊢⇩c m})"
proof -
have A_wf: "wf⇩t⇩r⇩m⇩s (set A)" and B_wf: "wf⇩t⇩r⇩m⇩s (set (B ⋅⇩l⇩i⇩s⇩t δ))"
and A'_wf': "wf⇩t⇩r⇩m⇩s (set A')" and B'_wf': "wf⇩t⇩r⇩m⇩s (set B')"
using finite_SMP_representationD[OF A_SMP_repr]
finite_SMP_representationD[OF B_SMP_repr]
A'_wf B'_wf
unfolding wf⇩t⇩r⇩m⇩s_code[symmetric] wf⇩t⇩r⇩m_code[symmetric] list_all_iff by blast+
have AB_fv_disj: "fv⇩s⇩e⇩t (set A) ∩ fv⇩s⇩e⇩t (set (B ⋅⇩l⇩i⇩s⇩t δ)) = {}"
using var_rename_fv_set_disjoint'[of "set A" "set B", unfolded δ_def[symmetric]] by simp
have "GSMP_disjoint (set A) (set (B ⋅⇩l⇩i⇩s⇩t δ)) ((f Sec) - {m. {} ⊢⇩c m})"
using ground_SMP_disjointI[OF AB_fv_disj A_SMP_repr B_SMP_repr Sec_wf AB_trms_disj]
unfolding GSMP_def GSMP_disjoint_def f_def by blast
moreover have "SMP (set A') ⊆ SMP (set A)" "SMP (set B') ⊆ SMP (set (B ⋅⇩l⇩i⇩s⇩t δ))"
using SMP_I'[OF A'_wf' A_wf A_inst] SMP_SMP_subset[of "set A'" "set A"]
SMP_I'[OF B'_wf' B_wf B_inst] SMP_SMP_subset[of "set B'" "set (B ⋅⇩l⇩i⇩s⇩t δ)"]
by blast+
ultimately show ?thesis unfolding GSMP_def GSMP_disjoint_def by auto
qed
end
end
Theory Labeled_Stateful_Strands
section ‹Labeled Stateful Strands›
theory Labeled_Stateful_Strands
imports Stateful_Strands Labeled_Strands
begin
subsection ‹Definitions›
text‹Syntax for stateful strand labels›
abbreviation Star_step ("⟨⋆, _⟩") where
"⟨⋆, (s::('a,'b) stateful_strand_step)⟩ ≡ (⋆, s)"
abbreviation LabelN_step ("⟨_, _⟩") where
"⟨(l::'a), (s::('b,'c) stateful_strand_step)⟩ ≡ (ln l, s)"
text‹Database projection›
abbreviation dbproj where "dbproj l D ≡ filter (λd. fst d = l) D"
text‹The type of labeled stateful strands›
type_synonym ('a,'b,'c) labeled_stateful_strand_step = "'c strand_label × ('a,'b) stateful_strand_step"
type_synonym ('a,'b,'c) labeled_stateful_strand = "('a,'b,'c) labeled_stateful_strand_step list"
text‹Dual strands›
fun dual⇩l⇩s⇩s⇩t⇩p::"('a,'b,'c) labeled_stateful_strand_step ⇒ ('a,'b,'c) labeled_stateful_strand_step"
where
"dual⇩l⇩s⇩s⇩t⇩p (l,send⟨t⟩) = (l,receive⟨t⟩)"
| "dual⇩l⇩s⇩s⇩t⇩p (l,receive⟨t⟩) = (l,send⟨t⟩)"
| "dual⇩l⇩s⇩s⇩t⇩p x = x"
definition dual⇩l⇩s⇩s⇩t::"('a,'b,'c) labeled_stateful_strand ⇒ ('a,'b,'c) labeled_stateful_strand"
where
"dual⇩l⇩s⇩s⇩t ≡ map dual⇩l⇩s⇩s⇩t⇩p"
text‹Substitution application›
fun subst_apply_labeled_stateful_strand_step::
"('a,'b,'c) labeled_stateful_strand_step ⇒ ('a,'b) subst ⇒
('a,'b,'c) labeled_stateful_strand_step"
(infix "⋅⇩l⇩s⇩s⇩t⇩p" 51) where
"(l,s) ⋅⇩l⇩s⇩s⇩t⇩p θ = (l,s ⋅⇩s⇩s⇩t⇩p θ)"
definition subst_apply_labeled_stateful_strand::
"('a,'b,'c) labeled_stateful_strand ⇒ ('a,'b) subst ⇒ ('a,'b,'c) labeled_stateful_strand"
(infix "⋅⇩l⇩s⇩s⇩t" 51) where
"S ⋅⇩l⇩s⇩s⇩t θ ≡ map (λx. x ⋅⇩l⇩s⇩s⇩t⇩p θ) S"
text‹Definitions lifted from stateful strands›
abbreviation wfrestrictedvars⇩l⇩s⇩s⇩t where "wfrestrictedvars⇩l⇩s⇩s⇩t S ≡ wfrestrictedvars⇩s⇩s⇩t (unlabel S)"
abbreviation ik⇩l⇩s⇩s⇩t where "ik⇩l⇩s⇩s⇩t S ≡ ik⇩s⇩s⇩t (unlabel S)"
abbreviation db⇩l⇩s⇩s⇩t where "db⇩l⇩s⇩s⇩t S ≡ db⇩s⇩s⇩t (unlabel S)"
abbreviation db'⇩l⇩s⇩s⇩t where "db'⇩l⇩s⇩s⇩t S ≡ db'⇩s⇩s⇩t (unlabel S)"
abbreviation trms⇩l⇩s⇩s⇩t where "trms⇩l⇩s⇩s⇩t S ≡ trms⇩s⇩s⇩t (unlabel S)"
abbreviation trms_proj⇩l⇩s⇩s⇩t where "trms_proj⇩l⇩s⇩s⇩t n S ≡ trms⇩s⇩s⇩t (proj_unl n S)"
abbreviation vars⇩l⇩s⇩s⇩t where "vars⇩l⇩s⇩s⇩t S ≡ vars⇩s⇩s⇩t (unlabel S)"
abbreviation vars_proj⇩l⇩s⇩s⇩t where "vars_proj⇩l⇩s⇩s⇩t n S ≡ vars⇩s⇩s⇩t (proj_unl n S)"
abbreviation bvars⇩l⇩s⇩s⇩t where "bvars⇩l⇩s⇩s⇩t S ≡ bvars⇩s⇩s⇩t (unlabel S)"
abbreviation fv⇩l⇩s⇩s⇩t where "fv⇩l⇩s⇩s⇩t S ≡ fv⇩s⇩s⇩t (unlabel S)"
text‹Labeled set-operations›
fun setops⇩l⇩s⇩s⇩t⇩p where
"setops⇩l⇩s⇩s⇩t⇩p (i,insert⟨t,s⟩) = {(i,t,s)}"
| "setops⇩l⇩s⇩s⇩t⇩p (i,delete⟨t,s⟩) = {(i,t,s)}"
| "setops⇩l⇩s⇩s⇩t⇩p (i,⟨_: t ∈ s⟩) = {(i,t,s)}"
| "setops⇩l⇩s⇩s⇩t⇩p (i,∀_⟨∨≠: _ ∨∉: F'⟩) = ((λ(t,s). (i,t,s)) ` set F')"
| "setops⇩l⇩s⇩s⇩t⇩p _ = {}"
definition setops⇩l⇩s⇩s⇩t where
"setops⇩l⇩s⇩s⇩t S ≡ ⋃(setops⇩l⇩s⇩s⇩t⇩p ` set S)"
subsection ‹Minor Lemmata›
lemma subst_lsst_nil[simp]: "[] ⋅⇩l⇩s⇩s⇩t δ = []"
by (simp add: subst_apply_labeled_stateful_strand_def)
lemma subst_lsst_cons: "a#A ⋅⇩l⇩s⇩s⇩t δ = (a ⋅⇩l⇩s⇩s⇩t⇩p δ)#(A ⋅⇩l⇩s⇩s⇩t δ)"
by (simp add: subst_apply_labeled_stateful_strand_def)
lemma subst_lsst_singleton: "[(l,s)] ⋅⇩l⇩s⇩s⇩t δ = [(l,s ⋅⇩s⇩s⇩t⇩p δ)]"
by (simp add: subst_apply_labeled_stateful_strand_def)
lemma subst_lsst_append: "A@B ⋅⇩l⇩s⇩s⇩t δ = (A ⋅⇩l⇩s⇩s⇩t δ)@(B ⋅⇩l⇩s⇩s⇩t δ)"
by (simp add: subst_apply_labeled_stateful_strand_def)
lemma subst_lsst_append_inv:
assumes "A ⋅⇩l⇩s⇩s⇩t δ = B1@B2"
shows "∃A1 A2. A = A1@A2 ∧ A1 ⋅⇩l⇩s⇩s⇩t δ = B1 ∧ A2 ⋅⇩l⇩s⇩s⇩t δ = B2"
using assms
proof (induction A arbitrary: B1 B2)
case (Cons a A)
note prems = Cons.prems
note IH = Cons.IH
show ?case
proof (cases B1)
case Nil
then obtain b B3 where "B2 = b#B3" "a ⋅⇩l⇩s⇩s⇩t⇩p δ = b" "A ⋅⇩l⇩s⇩s⇩t δ = B3"
using prems subst_lsst_cons by fastforce
thus ?thesis by (simp add: Nil subst_apply_labeled_stateful_strand_def)
next
case (Cons b B3)
hence "a ⋅⇩l⇩s⇩s⇩t⇩p δ = b" "A ⋅⇩l⇩s⇩s⇩t δ = B3@B2"
using prems by (simp_all add: subst_lsst_cons)
thus ?thesis by (metis Cons_eq_appendI Cons IH subst_lsst_cons)
qed
qed (metis append_is_Nil_conv subst_lsst_nil)
lemma subst_lsst_member[intro]: "x ∈ set A ⟹ x ⋅⇩l⇩s⇩s⇩t⇩p δ ∈ set (A ⋅⇩l⇩s⇩s⇩t δ)"
by (metis image_eqI set_map subst_apply_labeled_stateful_strand_def)
lemma subst_lsst_unlabel_cons: "unlabel ((l,b)#A ⋅⇩l⇩s⇩s⇩t θ) = (b ⋅⇩s⇩s⇩t⇩p θ)#(unlabel (A ⋅⇩l⇩s⇩s⇩t θ))"
by (simp add: subst_apply_labeled_stateful_strand_def)
lemma subst_lsst_unlabel: "unlabel (A ⋅⇩l⇩s⇩s⇩t δ) = unlabel A ⋅⇩s⇩s⇩t δ"
proof (induction A)
case (Cons a A)
then obtain l b where "a = (l,b)" by (metis surj_pair)
thus ?case
using Cons
by (simp add: subst_apply_labeled_stateful_strand_def subst_apply_stateful_strand_def)
qed simp
lemma subst_lsst_unlabel_member[intro]:
assumes "x ∈ set (unlabel A)"
shows "x ⋅⇩s⇩s⇩t⇩p δ ∈ set (unlabel (A ⋅⇩l⇩s⇩s⇩t δ))"
proof -
obtain l where x: "(l,x) ∈ set A" using assms unfolding unlabel_def by moura
thus ?thesis
using subst_lsst_member
by (metis unlabel_def in_set_zipE subst_apply_labeled_stateful_strand_step.simps zip_map_fst_snd)
qed
lemma subst_lsst_prefix:
assumes "prefix B (A ⋅⇩l⇩s⇩s⇩t θ)"
shows "∃C. C ⋅⇩l⇩s⇩s⇩t θ = B ∧ prefix C A"
using assms
proof (induction A rule: List.rev_induct)
case (snoc a A) thus ?case
proof (cases "B = A@[a] ⋅⇩l⇩s⇩s⇩t θ")
case False thus ?thesis
using snoc by (auto simp add: subst_lsst_append[of A] subst_lsst_cons)
qed auto
qed simp
lemma dual⇩l⇩s⇩s⇩t_nil[simp]: "dual⇩l⇩s⇩s⇩t [] = []"
by (simp add: dual⇩l⇩s⇩s⇩t_def)
lemma dual⇩l⇩s⇩s⇩t_Cons[simp]:
"dual⇩l⇩s⇩s⇩t ((l,send⟨t⟩)#A) = (l,receive⟨t⟩)#(dual⇩l⇩s⇩s⇩t A)"
"dual⇩l⇩s⇩s⇩t ((l,receive⟨t⟩)#A) = (l,send⟨t⟩)#(dual⇩l⇩s⇩s⇩t A)"
"dual⇩l⇩s⇩s⇩t ((l,⟨a: t ≐ s⟩)#A) = (l,⟨a: t ≐ s⟩)#(dual⇩l⇩s⇩s⇩t A)"
"dual⇩l⇩s⇩s⇩t ((l,insert⟨t,s⟩)#A) = (l,insert⟨t,s⟩)#(dual⇩l⇩s⇩s⇩t A)"
"dual⇩l⇩s⇩s⇩t ((l,delete⟨t,s⟩)#A) = (l,delete⟨t,s⟩)#(dual⇩l⇩s⇩s⇩t A)"
"dual⇩l⇩s⇩s⇩t ((l,⟨a: t ∈ s⟩)#A) = (l,⟨a: t ∈ s⟩)#(dual⇩l⇩s⇩s⇩t A)"
"dual⇩l⇩s⇩s⇩t ((l,∀X⟨∨≠: F ∨∉: G⟩)#A) = (l,∀X⟨∨≠: F ∨∉: G⟩)#(dual⇩l⇩s⇩s⇩t A)"
by (simp_all add: dual⇩l⇩s⇩s⇩t_def)
lemma dual⇩l⇩s⇩s⇩t_append[simp]: "dual⇩l⇩s⇩s⇩t (A@B) = dual⇩l⇩s⇩s⇩t A@dual⇩l⇩s⇩s⇩t B"
by (simp add: dual⇩l⇩s⇩s⇩t_def)
lemma dual⇩l⇩s⇩s⇩t⇩p_subst: "dual⇩l⇩s⇩s⇩t⇩p (s ⋅⇩l⇩s⇩s⇩t⇩p δ) = (dual⇩l⇩s⇩s⇩t⇩p s) ⋅⇩l⇩s⇩s⇩t⇩p δ"
proof -
obtain l x where s: "s = (l,x)" by moura
thus ?thesis by (cases x) (auto simp add: subst_apply_labeled_stateful_strand_def)
qed
lemma dual⇩l⇩s⇩s⇩t_subst: "dual⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ) = (dual⇩l⇩s⇩s⇩t S) ⋅⇩l⇩s⇩s⇩t δ"
proof (induction S)
case (Cons s S) thus ?case
using Cons dual⇩l⇩s⇩s⇩t⇩p_subst[of s δ]
by (simp add: dual⇩l⇩s⇩s⇩t_def subst_apply_labeled_stateful_strand_def)
qed (simp add: dual⇩l⇩s⇩s⇩t_def subst_apply_labeled_stateful_strand_def)
lemma dual⇩l⇩s⇩s⇩t_subst_unlabel: "unlabel (dual⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ)) = unlabel (dual⇩l⇩s⇩s⇩t S) ⋅⇩s⇩s⇩t δ"
by (metis dual⇩l⇩s⇩s⇩t_subst subst_lsst_unlabel)
lemma dual⇩l⇩s⇩s⇩t_subst_cons: "dual⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t σ) = (dual⇩l⇩s⇩s⇩t⇩p a ⋅⇩l⇩s⇩s⇩t⇩p σ)#(dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t σ))"
by (metis dual⇩l⇩s⇩s⇩t_subst list.simps(9) dual⇩l⇩s⇩s⇩t_def subst_apply_labeled_stateful_strand_def)
lemma dual⇩l⇩s⇩s⇩t_subst_append: "dual⇩l⇩s⇩s⇩t (A@B ⋅⇩l⇩s⇩s⇩t σ) = (dual⇩l⇩s⇩s⇩t A@dual⇩l⇩s⇩s⇩t B) ⋅⇩l⇩s⇩s⇩t σ"
by (metis (no_types) dual⇩l⇩s⇩s⇩t_subst dual⇩l⇩s⇩s⇩t_append)
lemma dual⇩l⇩s⇩s⇩t_subst_snoc: "dual⇩l⇩s⇩s⇩t (A@[a] ⋅⇩l⇩s⇩s⇩t σ) = (dual⇩l⇩s⇩s⇩t A ⋅⇩l⇩s⇩s⇩t σ)@[dual⇩l⇩s⇩s⇩t⇩p a ⋅⇩l⇩s⇩s⇩t⇩p σ]"
by (metis dual⇩l⇩s⇩s⇩t_def dual⇩l⇩s⇩s⇩t_subst dual⇩l⇩s⇩s⇩t_subst_cons list.map(1) map_append
subst_apply_labeled_stateful_strand_def)
lemma dual⇩l⇩s⇩s⇩t_memberD:
assumes "(l,a) ∈ set (dual⇩l⇩s⇩s⇩t A)"
shows "∃b. (l,b) ∈ set A ∧ dual⇩l⇩s⇩s⇩t⇩p (l,b) = (l,a)"
using assms
proof (induction A)
case (Cons c A)
hence "(l,a) ∈ set (dual⇩l⇩s⇩s⇩t A) ∨ dual⇩l⇩s⇩s⇩t⇩p c = (l,a)" unfolding dual⇩l⇩s⇩s⇩t_def by force
thus ?case
proof
assume "(l,a) ∈ set (dual⇩l⇩s⇩s⇩t A)" thus ?case using Cons.IH by auto
next
assume a: "dual⇩l⇩s⇩s⇩t⇩p c = (l,a)"
obtain i b where b: "c = (i,b)" by (metis surj_pair)
thus ?case using a by (cases b) auto
qed
qed simp
lemma dual⇩l⇩s⇩s⇩t⇩p_inv:
assumes "dual⇩l⇩s⇩s⇩t⇩p (l, a) = (k, b)"
shows "l = k"
and "a = receive⟨t⟩ ⟹ b = send⟨t⟩"
and "a = send⟨t⟩ ⟹ b = receive⟨t⟩"
and "(∄t. a = receive⟨t⟩ ∨ a = send⟨t⟩) ⟹ b = a"
proof -
show "l = k" using assms by (cases a) auto
show "a = receive⟨t⟩ ⟹ b = send⟨t⟩" using assms by (cases a) auto
show "a = send⟨t⟩ ⟹ b = receive⟨t⟩" using assms by (cases a) auto
show "(∄t. a = receive⟨t⟩ ∨ a = send⟨t⟩) ⟹ b = a" using assms by (cases a) auto
qed
lemma dual⇩l⇩s⇩s⇩t_self_inverse: "dual⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) = A"
proof (induction A)
case (Cons a A)
obtain l b where "a = (l,b)" by (metis surj_pair)
thus ?case using Cons by (cases b) auto
qed simp
lemma vars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq: "vars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) = vars⇩l⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
thus ?case using Cons.IH by (cases b) auto
qed simp
lemma fv⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq: "fv⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) = fv⇩l⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
thus ?case using Cons.IH by (cases b) auto
qed simp
lemma bvars⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq: "bvars⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) = bvars⇩l⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
thus ?case using Cons.IH by (cases b) simp+
qed simp
lemma vars⇩s⇩s⇩t_unlabel_Cons: "vars⇩l⇩s⇩s⇩t ((l,b)#A) = vars⇩s⇩s⇩t⇩p b ∪ vars⇩l⇩s⇩s⇩t A"
by (metis unlabel_Cons(1) vars⇩s⇩s⇩t_Cons)
lemma fv⇩s⇩s⇩t_unlabel_Cons: "fv⇩l⇩s⇩s⇩t ((l,b)#A) = fv⇩s⇩s⇩t⇩p b ∪ fv⇩l⇩s⇩s⇩t A"
by (metis unlabel_Cons(1) fv⇩s⇩s⇩t_Cons)
lemma bvars⇩s⇩s⇩t_unlabel_Cons: "bvars⇩l⇩s⇩s⇩t ((l,b)#A) = set (bvars⇩s⇩s⇩t⇩p b) ∪ bvars⇩l⇩s⇩s⇩t A"
by (metis unlabel_Cons(1) bvars⇩s⇩s⇩t_Cons)
lemma bvars⇩l⇩s⇩s⇩t_subst: "bvars⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ) = bvars⇩l⇩s⇩s⇩t A"
by (metis subst_lsst_unlabel bvars⇩s⇩s⇩t_subst)
lemma dual⇩l⇩s⇩s⇩t_member:
assumes "(l,x) ∈ set A"
and "¬is_Receive x" "¬is_Send x"
shows "(l,x) ∈ set (dual⇩l⇩s⇩s⇩t A)"
using assms
proof (induction A)
case (Cons a A) thus ?case using assms(2,3) by (cases x) (auto simp add: dual⇩l⇩s⇩s⇩t_def)
qed simp
lemma dual⇩l⇩s⇩s⇩t_unlabel_member:
assumes "x ∈ set (unlabel A)"
and "¬is_Receive x" "¬is_Send x"
shows "x ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
using assms dual⇩l⇩s⇩s⇩t_member[of _ _ A]
by (meson unlabel_in unlabel_mem_has_label)
lemma dual⇩l⇩s⇩s⇩t_steps_iff:
"(l,send⟨t⟩) ∈ set A ⟷ (l,receive⟨t⟩) ∈ set (dual⇩l⇩s⇩s⇩t A)"
"(l,receive⟨t⟩) ∈ set A ⟷ (l,send⟨t⟩) ∈ set (dual⇩l⇩s⇩s⇩t A)"
"(l,⟨c: t ≐ s⟩) ∈ set A ⟷ (l,⟨c: t ≐ s⟩) ∈ set (dual⇩l⇩s⇩s⇩t A)"
"(l,insert⟨t,s⟩) ∈ set A ⟷ (l,insert⟨t,s⟩) ∈ set (dual⇩l⇩s⇩s⇩t A)"
"(l,delete⟨t,s⟩) ∈ set A ⟷ (l,delete⟨t,s⟩) ∈ set (dual⇩l⇩s⇩s⇩t A)"
"(l,⟨c: t ∈ s⟩) ∈ set A ⟷ (l,⟨c: t ∈ s⟩) ∈ set (dual⇩l⇩s⇩s⇩t A)"
"(l,∀X⟨∨≠: F ∨∉: G⟩) ∈ set A ⟷ (l,∀X⟨∨≠: F ∨∉: G⟩) ∈ set (dual⇩l⇩s⇩s⇩t A)"
proof (induction A)
case (Cons a A)
obtain j b where a: "a = (j,b)" by (metis surj_pair)
{ case 1 thus ?case by (cases b) (simp_all add: Cons.IH(1) a dual⇩l⇩s⇩s⇩t_def) }
{ case 2 thus ?case by (cases b) (simp_all add: Cons.IH(2) a dual⇩l⇩s⇩s⇩t_def) }
{ case 3 thus ?case by (cases b) (simp_all add: Cons.IH(3) a dual⇩l⇩s⇩s⇩t_def) }
{ case 4 thus ?case by (cases b) (simp_all add: Cons.IH(4) a dual⇩l⇩s⇩s⇩t_def) }
{ case 5 thus ?case by (cases b) (simp_all add: Cons.IH(5) a dual⇩l⇩s⇩s⇩t_def) }
{ case 6 thus ?case by (cases b) (simp_all add: Cons.IH(6) a dual⇩l⇩s⇩s⇩t_def) }
{ case 7 thus ?case by (cases b) (simp_all add: Cons.IH(7) a dual⇩l⇩s⇩s⇩t_def) }
qed (simp_all add: dual⇩l⇩s⇩s⇩t_def)
lemma dual⇩l⇩s⇩s⇩t_unlabel_steps_iff:
"send⟨t⟩ ∈ set (unlabel A) ⟷ receive⟨t⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
"receive⟨t⟩ ∈ set (unlabel A) ⟷ send⟨t⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
"⟨c: t ≐ s⟩ ∈ set (unlabel A) ⟷ ⟨c: t ≐ s⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
"insert⟨t,s⟩ ∈ set (unlabel A) ⟷ insert⟨t,s⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
"delete⟨t,s⟩ ∈ set (unlabel A) ⟷ delete⟨t,s⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
"⟨c: t ∈ s⟩ ∈ set (unlabel A) ⟷ ⟨c: t ∈ s⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
"∀X⟨∨≠: F ∨∉: G⟩ ∈ set (unlabel A) ⟷ ∀X⟨∨≠: F ∨∉: G⟩ ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
using dual⇩l⇩s⇩s⇩t_steps_iff(1,2)[of _ t A]
dual⇩l⇩s⇩s⇩t_steps_iff(3,6)[of _ c t s A]
dual⇩l⇩s⇩s⇩t_steps_iff(4,5)[of _ t s A]
dual⇩l⇩s⇩s⇩t_steps_iff(7)[of _ X F G A]
by (meson unlabel_in unlabel_mem_has_label)+
lemma dual⇩l⇩s⇩s⇩t_list_all:
"list_all is_Receive (unlabel A) ⟹ list_all is_Send (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_Send (unlabel A) ⟹ list_all is_Receive (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_Equality (unlabel A) ⟹ list_all is_Equality (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_Insert (unlabel A) ⟹ list_all is_Insert (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_Delete (unlabel A) ⟹ list_all is_Delete (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_InSet (unlabel A) ⟹ list_all is_InSet (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_NegChecks (unlabel A) ⟹ list_all is_NegChecks (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_Assignment (unlabel A) ⟹ list_all is_Assignment (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_Check (unlabel A) ⟹ list_all is_Check (unlabel (dual⇩l⇩s⇩s⇩t A))"
"list_all is_Update (unlabel A) ⟹ list_all is_Update (unlabel (dual⇩l⇩s⇩s⇩t A))"
proof (induct A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
{ case 1 thus ?case using Cons.hyps(1) a by (cases b) auto }
{ case 2 thus ?case using Cons.hyps(2) a by (cases b) auto }
{ case 3 thus ?case using Cons.hyps(3) a by (cases b) auto }
{ case 4 thus ?case using Cons.hyps(4) a by (cases b) auto }
{ case 5 thus ?case using Cons.hyps(5) a by (cases b) auto }
{ case 6 thus ?case using Cons.hyps(6) a by (cases b) auto }
{ case 7 thus ?case using Cons.hyps(7) a by (cases b) auto }
{ case 8 thus ?case using Cons.hyps(8) a by (cases b) auto }
{ case 9 thus ?case using Cons.hyps(9) a by (cases b) auto }
{ case 10 thus ?case using Cons.hyps(10) a by (cases b) auto }
qed simp_all
lemma dual⇩l⇩s⇩s⇩t_in_set_prefix_obtain:
assumes "s ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))"
shows "∃l B s'. (l,s) = dual⇩l⇩s⇩s⇩t⇩p (l,s') ∧ prefix (B@[(l,s')]) A"
using assms
proof (induction A rule: List.rev_induct)
case (snoc a A)
obtain i b where a: "a = (i,b)" by (metis surj_pair)
show ?case using snoc
proof (cases "s ∈ set (unlabel (dual⇩l⇩s⇩s⇩t A))")
case False thus ?thesis
using a snoc.prems unlabel_append[of "dual⇩l⇩s⇩s⇩t A" "dual⇩l⇩s⇩s⇩t [a]"] dual⇩l⇩s⇩s⇩t_append[of A "[a]"]
by (cases b) (force simp add: unlabel_def dual⇩l⇩s⇩s⇩t_def)+
qed auto
qed simp
lemma dual⇩l⇩s⇩s⇩t_in_set_prefix_obtain_subst:
assumes "s ∈ set (unlabel (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t θ)))"
shows "∃l B s'. (l,s) = dual⇩l⇩s⇩s⇩t⇩p ((l,s') ⋅⇩l⇩s⇩s⇩t⇩p θ) ∧ prefix ((B ⋅⇩l⇩s⇩s⇩t θ)@[(l,s') ⋅⇩l⇩s⇩s⇩t⇩p θ]) (A ⋅⇩l⇩s⇩s⇩t θ)"
proof -
obtain B l s' where B: "(l,s) = dual⇩l⇩s⇩s⇩t⇩p (l,s')" "prefix (B@[(l,s')]) (A ⋅⇩l⇩s⇩s⇩t θ)"
using dual⇩l⇩s⇩s⇩t_in_set_prefix_obtain[OF assms] by moura
obtain C where C: "C ⋅⇩l⇩s⇩s⇩t θ = B@[(l,s')]"
using subst_lsst_prefix[OF B(2)] by moura
obtain D u where D: "C = D@[(l,u)]" "D ⋅⇩l⇩s⇩s⇩t θ = B" "[(l,u)] ⋅⇩l⇩s⇩s⇩t θ = [(l, s')]"
using subst_lsst_prefix[OF B(2)] subst_lsst_append_inv[OF C(1)]
by (auto simp add: subst_apply_labeled_stateful_strand_def)
show ?thesis
using B D subst_lsst_cons subst_lsst_singleton
by (metis (no_types, lifting) nth_append_length)
qed
lemma trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq: "trms⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) = trms⇩l⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
thus ?case using Cons.IH by (cases b) auto
qed simp
lemma trms⇩s⇩s⇩t_unlabel_subst_cons:
"trms⇩l⇩s⇩s⇩t ((l,b)#A ⋅⇩l⇩s⇩s⇩t δ) = trms⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) ∪ trms⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
by (metis subst_lsst_unlabel trms⇩s⇩s⇩t_subst_cons unlabel_Cons(1))
lemma trms⇩s⇩s⇩t_unlabel_subst:
assumes "bvars⇩l⇩s⇩s⇩t S ∩ subst_domain θ = {}"
shows "trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t θ) = trms⇩l⇩s⇩s⇩t S ⋅⇩s⇩e⇩t θ"
by (metis trms⇩s⇩s⇩t_subst[OF assms] subst_lsst_unlabel)
lemma trms⇩s⇩s⇩t_unlabel_subst':
fixes t::"('a,'b) term" and δ::"('a,'b) subst"
assumes "t ∈ trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ)"
shows "∃s ∈ trms⇩l⇩s⇩s⇩t S. ∃X. set X ⊆ bvars⇩l⇩s⇩s⇩t S ∧ t = s ⋅ rm_vars (set X) δ"
using assms
proof (induction S)
case (Cons a S)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
hence "t ∈ trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ) ∨ t ∈ trms⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ)"
using Cons.prems trms⇩s⇩s⇩t_unlabel_subst_cons by fast
thus ?case
proof
assume *: "t ∈ trms⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ)"
show ?thesis using trms⇩s⇩s⇩t⇩p_subst''[OF *] a by auto
next
assume *: "t ∈ trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ)"
show ?thesis using Cons.IH[OF *] a by auto
qed
qed simp
lemma trms⇩s⇩s⇩t_unlabel_subst'':
fixes t::"('a,'b) term" and δ θ::"('a,'b) subst"
assumes "t ∈ trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ) ⋅⇩s⇩e⇩t θ"
shows "∃s ∈ trms⇩l⇩s⇩s⇩t S. ∃X. set X ⊆ bvars⇩l⇩s⇩s⇩t S ∧ t = s ⋅ rm_vars (set X) δ ∘⇩s θ"
proof -
obtain s where s: "s ∈ trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t δ)" "t = s ⋅ θ" using assms by moura
show ?thesis using trms⇩s⇩s⇩t_unlabel_subst'[OF s(1)] s(2) by auto
qed
lemma trms⇩s⇩s⇩t_unlabel_dual_subst_cons:
"trms⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t σ)) = (trms⇩s⇩s⇩t⇩p (snd a ⋅⇩s⇩s⇩t⇩p σ)) ∪ (trms⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t σ)))"
proof -
obtain l b where a: "a = (l,b)" by (metis surj_pair)
thus ?thesis using a dual⇩l⇩s⇩s⇩t_subst_cons[of a A σ] by (cases b) auto
qed
lemma dual⇩l⇩s⇩s⇩t_funs_term:
"⋃(funs_term ` (trms⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t S)))) = ⋃(funs_term ` (trms⇩s⇩s⇩t (unlabel S)))"
using trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq by fast
lemma dual⇩l⇩s⇩s⇩t_db⇩l⇩s⇩s⇩t:
"db'⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) = db'⇩l⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
thus ?case using Cons by (cases b) auto
qed simp
lemma db⇩s⇩s⇩t_unlabel_append:
"db'⇩l⇩s⇩s⇩t (A@B) I D = db'⇩l⇩s⇩s⇩t B I (db'⇩l⇩s⇩s⇩t A I D)"
by (metis db⇩s⇩s⇩t_append unlabel_append)
lemma db⇩s⇩s⇩t_dual⇩l⇩s⇩s⇩t:
"db'⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t (T ⋅⇩l⇩s⇩s⇩t δ))) ℐ D = db'⇩s⇩s⇩t (unlabel (T ⋅⇩l⇩s⇩s⇩t δ)) ℐ D"
proof (induction T arbitrary: D)
case (Cons x T)
obtain l s where "x = (l,s)" by moura
thus ?case
using Cons
by (cases s) (simp_all add: unlabel_def dual⇩l⇩s⇩s⇩t_def subst_apply_labeled_stateful_strand_def)
qed (simp add: unlabel_def dual⇩l⇩s⇩s⇩t_def subst_apply_labeled_stateful_strand_def)
lemma labeled_list_insert_eq_cases:
"d ∉ set (unlabel D) ⟹ List.insert d (unlabel D) = unlabel (List.insert (i,d) D)"
"(i,d) ∈ set D ⟹ List.insert d (unlabel D) = unlabel (List.insert (i,d) D)"
unfolding unlabel_def
by (metis (no_types, hide_lams) List.insert_def image_eqI list.simps(9) set_map snd_conv,
metis in_set_insert set_zip_rightD zip_map_fst_snd)
lemma labeled_list_insert_eq_ex_cases:
"List.insert d (unlabel D) = unlabel (List.insert (i,d) D) ∨
(∃j. (j,d) ∈ set D ∧ List.insert d (unlabel D) = unlabel (List.insert (j,d) D))"
using labeled_list_insert_eq_cases unfolding unlabel_def
by (metis in_set_impl_in_set_zip2 length_map zip_map_fst_snd)
lemma proj_subst: "proj l (A ⋅⇩l⇩s⇩s⇩t δ) = proj l A ⋅⇩l⇩s⇩s⇩t δ"
proof (induction A)
case (Cons a A)
obtain l b where "a = (l,b)" by (metis surj_pair)
thus ?case using Cons unfolding proj_def subst_apply_labeled_stateful_strand_def by force
qed simp
lemma proj_set_subset[simp]:
"set (proj n A) ⊆ set A"
unfolding proj_def by auto
lemma proj_proj_set_subset[simp]:
"set (proj n (proj m A)) ⊆ set (proj n A)"
"set (proj n (proj m A)) ⊆ set (proj m A)"
"set (proj_unl n (proj m A)) ⊆ set (proj_unl n A)"
"set (proj_unl n (proj m A)) ⊆ set (proj_unl m A)"
unfolding unlabel_def proj_def by auto
lemma proj_in_set_iff:
"(ln i, d) ∈ set (proj i D) ⟷ (ln i, d) ∈ set D"
"(⋆, d) ∈ set (proj i D) ⟷ (⋆, d) ∈ set D"
unfolding proj_def by auto
lemma proj_list_insert:
"proj i (List.insert (ln i,d) D) = List.insert (ln i,d) (proj i D)"
"proj i (List.insert (⋆,d) D) = List.insert (⋆,d) (proj i D)"
"i ≠ j ⟹ proj i (List.insert (ln j,d) D) = proj i D"
unfolding List.insert_def proj_def by auto
lemma proj_filter: "proj i [d←D. d ∉ set Di] = [d←proj i D. d ∉ set Di]"
by (simp_all add: proj_def conj_commute)
lemma proj_list_Cons:
"proj i ((ln i,d)#D) = (ln i,d)#proj i D"
"proj i ((⋆,d)#D) = (⋆,d)#proj i D"
"i ≠ j ⟹ proj i ((ln j,d)#D) = proj i D"
unfolding List.insert_def proj_def by auto
lemma proj_dual⇩l⇩s⇩s⇩t:
"proj l (dual⇩l⇩s⇩s⇩t A) = dual⇩l⇩s⇩s⇩t (proj l A)"
proof (induction A)
case (Cons a A)
obtain k b where "a = (k,b)" by (metis surj_pair)
thus ?case using Cons unfolding dual⇩l⇩s⇩s⇩t_def proj_def by (cases b) auto
qed simp
lemma proj_instance_ex:
assumes B: "∀b ∈ set B. ∃a ∈ set A. ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧ P δ"
and b: "b ∈ set (proj l B)"
shows "∃a ∈ set (proj l A). ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧ P δ"
proof -
obtain a δ where a: "a ∈ set A" "b = a ⋅⇩l⇩s⇩s⇩t⇩p δ" "P δ" using B b proj_set_subset by fast
obtain k b' where b': "b = (k, b')" "k = (ln l) ∨ k = ⋆" using b proj_in_setD by metis
obtain a' where a': "a = (k, a')" using b'(1) a(2) by (cases a) simp_all
show ?thesis using a a' b'(2) unfolding proj_def by auto
qed
lemma proj_dbproj:
"dbproj (ln i) (proj i D) = dbproj (ln i) D"
"dbproj ⋆ (proj i D) = dbproj ⋆ D"
"i ≠ j ⟹ dbproj (ln j) (proj i D) = []"
unfolding proj_def by (induct D) auto
lemma dbproj_Cons:
"dbproj i ((i,d)#D) = (i,d)#dbproj i D"
"i ≠ j ⟹ dbproj j ((i,d)#D) = dbproj j D"
by auto
lemma dbproj_subset[simp]:
"set (unlabel (dbproj i D)) ⊆ set (unlabel D)"
unfolding unlabel_def by auto
lemma dbproj_subseq:
assumes "Di ∈ set (subseqs (dbproj k D))"
shows "dbproj k Di = Di" (is ?A)
and "i ≠ k ⟹ dbproj i Di = []" (is "i ≠ k ⟹ ?B")
proof -
have *: "set Di ⊆ set (dbproj k D)" using subseqs_powset[of "dbproj k D"] assms by auto
thus ?A by (metis filter_True filter_set member_filter subsetCE)
have "⋀j d. (j,d) ∈ set Di ⟹ j = k" using * by auto
moreover have "⋀j d. (j,d) ∈ set (dbproj i Di) ⟹ j = i" by auto
moreover have "⋀j d. (j,d) ∈ set (dbproj i Di) ⟹ (j,d) ∈ set Di" by auto
ultimately show "i ≠ k ⟹ ?B" by (metis set_empty subrelI subset_empty)
qed
lemma dbproj_subseq_subset:
assumes "Di ∈ set (subseqs (dbproj i D))"
shows "set Di ⊆ set D"
by (metis Pow_iff assms filter_set image_eqI member_filter subseqs_powset subsetCE subsetI)
lemma dbproj_subseq_in_subseqs:
assumes "Di ∈ set (subseqs (dbproj i D))"
shows "Di ∈ set (subseqs D)"
using assms in_set_subseqs subseq_filter_left subseq_order.dual_order.trans by blast
lemma proj_subseq:
assumes "Di ∈ set (subseqs (dbproj (ln j) D))" "j ≠ i"
shows "[d←proj i D. d ∉ set Di] = proj i D"
proof -
have "set Di ⊆ set (dbproj (ln j) D)" using subseqs_powset[of "dbproj (ln j) D"] assms by auto
hence "⋀k d. (k,d) ∈ set Di ⟹ k = ln j" by auto
moreover have "⋀k d. (k,d) ∈ set (proj i D) ⟹ k ≠ ln j"
using assms(2) unfolding proj_def by auto
ultimately have "⋀d. d ∈ set (proj i D) ⟹ d ∉ set Di" by auto
thus ?thesis by simp
qed
lemma unlabel_subseqsD:
assumes "A ∈ set (subseqs (unlabel B))"
shows "∃C ∈ set (subseqs B). unlabel C = A"
using assms map_subseqs unfolding unlabel_def by (metis imageE set_map)
lemma unlabel_filter_eq:
assumes "∀(j, p) ∈ set A ∪ B. ∀(k, q) ∈ set A ∪ B. p = q ⟶ j = k" (is "?P (set A)")
shows "[d←unlabel A. d ∉ snd ` B] = unlabel [d←A. d ∉ B]"
using assms unfolding unlabel_def
proof (induction A)
case (Cons a A)
have "set A ⊆ set (a#A)" "{a} ⊆ set (a#A)" by auto
hence *: "?P (set A)" "?P {a}" using Cons.prems by fast+
hence IH: "[d←map snd A . d ∉ snd ` B] = map snd [d←A . d ∉ B]" using Cons.IH by auto
{ assume "snd a ∈ snd ` B"
then obtain b where b: "b ∈ B" "snd a = snd b" by moura
hence "fst a = fst b" using *(2) by auto
hence "a ∈ B" using b by (metis surjective_pairing)
} hence **: "a ∉ B ⟹ snd a ∉ snd ` B" by metis
show ?case by (cases "a ∈ B") (simp add: ** IH)+
qed simp
lemma subseqs_mem_dbproj:
assumes "Di ∈ set (subseqs D)" "list_all (λd. fst d = i) Di"
shows "Di ∈ set (subseqs (dbproj i D))"
using assms
proof (induction D arbitrary: Di)
case (Cons di D)
obtain d j where di: "di = (j,d)" by (metis surj_pair)
show ?case
proof (cases "Di ∈ set (subseqs D)")
case True
hence "Di ∈ set (subseqs (dbproj i D))" using Cons.IH Cons.prems by auto
thus ?thesis using subseqs_Cons by auto
next
case False
then obtain Di' where Di': "Di = di#Di'" using Cons.prems(1)
by (metis (mono_tags, lifting) Un_iff imageE set_append set_map subseqs.simps(2))
hence "Di' ∈ set (subseqs D)" using Cons.prems(1) False
by (metis (no_types, lifting) UnE imageE list.inject set_append set_map subseqs.simps(2))
hence "Di' ∈ set (subseqs (dbproj i D))" using Cons.IH Cons.prems Di' by auto
moreover have "i = j" using Di' di Cons.prems(2) by auto
hence "dbproj i (di#D) = di#dbproj i D" by (simp add: di)
ultimately show ?thesis using Di'
by (metis (no_types, lifting) UnCI image_eqI set_append set_map subseqs.simps(2))
qed
qed simp
lemma unlabel_subst: "unlabel S ⋅⇩s⇩s⇩t δ = unlabel (S ⋅⇩l⇩s⇩s⇩t δ)"
unfolding unlabel_def subst_apply_stateful_strand_def subst_apply_labeled_stateful_strand_def
by auto
lemma subterms_subst_lsst:
assumes "∀x ∈ fv⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t S). (∃f. σ x = Fun f []) ∨ (∃y. σ x = Var y)"
and "bvars⇩l⇩s⇩s⇩t S ∩ subst_domain σ = {}"
shows "subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t σ)) = subterms⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t S) ⋅⇩s⇩e⇩t σ"
using subterms_subst''[OF assms(1)] trms⇩s⇩s⇩t_subst[OF assms(2)] unlabel_subst[of S σ]
by simp
lemma subterms_subst_lsst_ik:
assumes "∀x ∈ fv⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t S). (∃f. σ x = Fun f []) ∨ (∃y. σ x = Var y)"
shows "subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t σ)) = subterms⇩s⇩e⇩t (ik⇩l⇩s⇩s⇩t S) ⋅⇩s⇩e⇩t σ"
using subterms_subst''[OF assms(1)] ik⇩s⇩s⇩t_subst[of "unlabel S" σ] unlabel_subst[of S σ]
by simp
lemma labeled_stateful_strand_subst_comp:
assumes "range_vars δ ∩ bvars⇩l⇩s⇩s⇩t S = {}"
shows "S ⋅⇩l⇩s⇩s⇩t δ ∘⇩s θ = (S ⋅⇩l⇩s⇩s⇩t δ) ⋅⇩l⇩s⇩s⇩t θ"
using assms
proof (induction S)
case (Cons s S)
obtain l x where s: "s = (l,x)" by (metis surj_pair)
hence IH: "S ⋅⇩l⇩s⇩s⇩t δ ∘⇩s θ = (S ⋅⇩l⇩s⇩s⇩t δ) ⋅⇩l⇩s⇩s⇩t θ" using Cons by auto
have "x ⋅⇩s⇩s⇩t⇩p δ ∘⇩s θ = (x ⋅⇩s⇩s⇩t⇩p δ) ⋅⇩s⇩s⇩t⇩p θ"
using s Cons.prems stateful_strand_step_subst_comp[of δ x θ] by auto
thus ?case using s IH by (simp add: subst_apply_labeled_stateful_strand_def)
qed simp
lemma sst_vars_proj_subset[simp]:
"fv⇩s⇩s⇩t (proj_unl n A) ⊆ fv⇩s⇩s⇩t (unlabel A)"
"bvars⇩s⇩s⇩t (proj_unl n A) ⊆ bvars⇩s⇩s⇩t (unlabel A)"
"vars⇩s⇩s⇩t (proj_unl n A) ⊆ vars⇩s⇩s⇩t (unlabel A)"
using vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "unlabel A"]
vars⇩s⇩s⇩t_is_fv⇩s⇩s⇩t_bvars⇩s⇩s⇩t[of "proj_unl n A"]
unfolding unlabel_def proj_def by auto
lemma trms⇩s⇩s⇩t_proj_subset[simp]:
"trms⇩s⇩s⇩t (proj_unl n A) ⊆ trms⇩s⇩s⇩t (unlabel A)" (is ?A)
"trms⇩s⇩s⇩t (proj_unl m (proj n A)) ⊆ trms⇩s⇩s⇩t (proj_unl n A)" (is ?B)
"trms⇩s⇩s⇩t (proj_unl m (proj n A)) ⊆ trms⇩s⇩s⇩t (proj_unl m A)" (is ?C)
proof -
show ?A unfolding unlabel_def proj_def by auto
show ?B using trms⇩s⇩s⇩t_mono[OF proj_proj_set_subset(4)] by metis
show ?C using trms⇩s⇩s⇩t_mono[OF proj_proj_set_subset(3)] by metis
qed
lemma trms⇩s⇩s⇩t_unlabel_prefix_subset:
"trms⇩s⇩s⇩t (unlabel A) ⊆ trms⇩s⇩s⇩t (unlabel (A@B))" (is ?A)
"trms⇩s⇩s⇩t (proj_unl n A) ⊆ trms⇩s⇩s⇩t (proj_unl n (A@B))" (is ?B)
using trms⇩s⇩s⇩t_mono[of "proj_unl n A" "proj_unl n (A@B)"]
unfolding unlabel_def proj_def by auto
lemma trms⇩s⇩s⇩t_unlabel_suffix_subset:
"trms⇩s⇩s⇩t (unlabel B) ⊆ trms⇩s⇩s⇩t (unlabel (A@B))"
"trms⇩s⇩s⇩t (proj_unl n B) ⊆ trms⇩s⇩s⇩t (proj_unl n (A@B))"
using trms⇩s⇩s⇩t_mono[of "proj_unl n B" "proj_unl n (A@B)"]
unfolding unlabel_def proj_def by auto
lemma setops⇩l⇩s⇩s⇩t⇩pD:
assumes p: "p ∈ setops⇩l⇩s⇩s⇩t⇩p a"
shows "fst p = fst a" (is ?P)
and "is_Update (snd a) ∨ is_InSet (snd a) ∨ is_NegChecks (snd a)" (is ?Q)
proof -
obtain l k p' a' where a: "p = (l,p')" "a = (k,a')" by (metis surj_pair)
show ?P using p a by (cases a') auto
show ?Q using p a by (cases a') auto
qed
lemma setops⇩l⇩s⇩s⇩t_nil[simp]:
"setops⇩l⇩s⇩s⇩t [] = {}"
by (simp add: setops⇩l⇩s⇩s⇩t_def)
lemma setops⇩l⇩s⇩s⇩t_cons[simp]:
"setops⇩l⇩s⇩s⇩t (x#S) = setops⇩l⇩s⇩s⇩t⇩p x ∪ setops⇩l⇩s⇩s⇩t S"
by (simp add: setops⇩l⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t_proj_subset:
"setops⇩s⇩s⇩t (proj_unl n A) ⊆ setops⇩s⇩s⇩t (unlabel A)"
"setops⇩s⇩s⇩t (proj_unl m (proj n A)) ⊆ setops⇩s⇩s⇩t (proj_unl n A)"
"setops⇩s⇩s⇩t (proj_unl m (proj n A)) ⊆ setops⇩s⇩s⇩t (proj_unl m A)"
unfolding unlabel_def proj_def
proof (induction A)
case (Cons a A)
obtain l b where lb: "a = (l,b)" by moura
{ case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops⇩s⇩s⇩t_def) }
{ case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops⇩s⇩s⇩t_def) }
{ case 3 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops⇩s⇩s⇩t_def) }
qed simp_all
lemma setops⇩s⇩s⇩t_unlabel_prefix_subset:
"setops⇩s⇩s⇩t (unlabel A) ⊆ setops⇩s⇩s⇩t (unlabel (A@B))"
"setops⇩s⇩s⇩t (proj_unl n A) ⊆ setops⇩s⇩s⇩t (proj_unl n (A@B))"
unfolding unlabel_def proj_def
proof (induction A)
case (Cons a A)
obtain l b where lb: "a = (l,b)" by moura
{ case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops⇩s⇩s⇩t_def) }
{ case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops⇩s⇩s⇩t_def) }
qed (simp_all add: setops⇩s⇩s⇩t_def)
lemma setops⇩s⇩s⇩t_unlabel_suffix_subset:
"setops⇩s⇩s⇩t (unlabel B) ⊆ setops⇩s⇩s⇩t (unlabel (A@B))"
"setops⇩s⇩s⇩t (proj_unl n B) ⊆ setops⇩s⇩s⇩t (proj_unl n (A@B))"
unfolding unlabel_def proj_def
proof (induction A)
case (Cons a A)
obtain l b where lb: "a = (l,b)" by moura
{ case 1 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops⇩s⇩s⇩t_def) }
{ case 2 thus ?case using Cons.IH lb by (cases b) (auto simp add: setops⇩s⇩s⇩t_def) }
qed simp_all
lemma setops⇩l⇩s⇩s⇩t_proj_subset:
"setops⇩l⇩s⇩s⇩t (proj n A) ⊆ setops⇩l⇩s⇩s⇩t A"
"setops⇩l⇩s⇩s⇩t (proj m (proj n A)) ⊆ setops⇩l⇩s⇩s⇩t (proj n A)"
unfolding proj_def setops⇩l⇩s⇩s⇩t_def by auto
lemma setops⇩l⇩s⇩s⇩t_prefix_subset:
"setops⇩l⇩s⇩s⇩t A ⊆ setops⇩l⇩s⇩s⇩t (A@B)"
"setops⇩l⇩s⇩s⇩t (proj n A) ⊆ setops⇩l⇩s⇩s⇩t (proj n (A@B))"
unfolding proj_def setops⇩l⇩s⇩s⇩t_def by auto
lemma setops⇩l⇩s⇩s⇩t_suffix_subset:
"setops⇩l⇩s⇩s⇩t B ⊆ setops⇩l⇩s⇩s⇩t (A@B)"
"setops⇩l⇩s⇩s⇩t (proj n B) ⊆ setops⇩l⇩s⇩s⇩t (proj n (A@B))"
unfolding proj_def setops⇩l⇩s⇩s⇩t_def by auto
lemma setops⇩l⇩s⇩s⇩t_mono:
"set M ⊆ set N ⟹ setops⇩l⇩s⇩s⇩t M ⊆ setops⇩l⇩s⇩s⇩t N"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
lemma trms⇩s⇩s⇩t_unlabel_subset_if_no_label:
"¬list_ex (is_LabelN l) A ⟹ trms⇩l⇩s⇩s⇩t (proj l A) ⊆ trms⇩l⇩s⇩s⇩t (proj l' A)"
by (rule trms⇩s⇩s⇩t_mono[OF proj_subset_if_no_label(2)[of l A l']])
lemma setops⇩s⇩s⇩t_unlabel_subset_if_no_label:
"¬list_ex (is_LabelN l) A ⟹ setops⇩s⇩s⇩t (proj_unl l A) ⊆ setops⇩s⇩s⇩t (proj_unl l' A)"
by (rule setops⇩s⇩s⇩t_mono[OF proj_subset_if_no_label(2)[of l A l']])
lemma setops⇩l⇩s⇩s⇩t_proj_subset_if_no_label:
"¬list_ex (is_LabelN l) A ⟹ setops⇩l⇩s⇩s⇩t (proj l A) ⊆ setops⇩l⇩s⇩s⇩t (proj l' A)"
by (rule setops⇩l⇩s⇩s⇩t_mono[OF proj_subset_if_no_label(1)[of l A l']])
lemma setops⇩l⇩s⇩s⇩t⇩p_subst_cases[simp]:
"setops⇩l⇩s⇩s⇩t⇩p ((l,send⟨t⟩) ⋅⇩l⇩s⇩s⇩t⇩p δ) = {}"
"setops⇩l⇩s⇩s⇩t⇩p ((l,receive⟨t⟩) ⋅⇩l⇩s⇩s⇩t⇩p δ) = {}"
"setops⇩l⇩s⇩s⇩t⇩p ((l,⟨ac: s ≐ t⟩) ⋅⇩l⇩s⇩s⇩t⇩p δ) = {}"
"setops⇩l⇩s⇩s⇩t⇩p ((l,insert⟨t,s⟩) ⋅⇩l⇩s⇩s⇩t⇩p δ) = {(l,t ⋅ δ,s ⋅ δ)}"
"setops⇩l⇩s⇩s⇩t⇩p ((l,delete⟨t,s⟩) ⋅⇩l⇩s⇩s⇩t⇩p δ) = {(l,t ⋅ δ,s ⋅ δ)}"
"setops⇩l⇩s⇩s⇩t⇩p ((l,⟨ac: t ∈ s⟩) ⋅⇩l⇩s⇩s⇩t⇩p δ) = {(l,t ⋅ δ,s ⋅ δ)}"
"setops⇩l⇩s⇩s⇩t⇩p ((l,∀X⟨∨≠: F ∨∉: F'⟩) ⋅⇩l⇩s⇩s⇩t⇩p δ) =
((λ(t,s). (l,t ⋅ rm_vars (set X) δ,s ⋅ rm_vars (set X) δ)) ` set F')" (is "?A = ?B")
proof -
have "?A = (λ(t,s). (l,t,s)) ` set (F' ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ)" by auto
thus "?A = ?B" unfolding subst_apply_pairs_def by auto
qed simp_all
lemma setops⇩l⇩s⇩s⇩t⇩p_subst:
assumes "set (bvars⇩s⇩s⇩t⇩p (snd a)) ∩ subst_domain θ = {}"
shows "setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p θ) = (λp. (fst a,snd p ⋅⇩p θ)) ` setops⇩l⇩s⇩s⇩t⇩p a"
proof -
obtain l a' where a: "a = (l,a')" by (metis surj_pair)
show ?thesis
proof (cases a')
case (NegChecks X F G)
hence *: "rm_vars (set X) θ = θ" using a assms rm_vars_apply'[of θ "set X"] by auto
have "setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p θ) = (λp. (fst a, p)) ` set (G ⋅⇩p⇩a⇩i⇩r⇩s θ)"
using * NegChecks a by auto
moreover have "setops⇩l⇩s⇩s⇩t⇩p a = (λp. (fst a, p)) ` set G" using NegChecks a by simp
hence "(λp. (fst a,snd p ⋅⇩p θ)) ` setops⇩l⇩s⇩s⇩t⇩p a = (λp. (fst a, p ⋅⇩p θ)) ` set G"
by (metis (mono_tags, lifting) image_cong image_image snd_conv)
hence "(λp. (fst a,snd p ⋅⇩p θ)) ` setops⇩l⇩s⇩s⇩t⇩p a = (λp. (fst a, p)) ` (set G ⋅⇩p⇩s⇩e⇩t θ)"
unfolding case_prod_unfold by auto
ultimately show ?thesis by (simp add: subst_apply_pairs_def)
qed (use a in simp_all)
qed
lemma setops⇩l⇩s⇩s⇩t⇩p_subst':
assumes "set (bvars⇩s⇩s⇩t⇩p (snd a)) ∩ subst_domain θ = {}"
shows "setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p θ) = (λ(i,p). (i,p ⋅⇩p θ)) ` setops⇩l⇩s⇩s⇩t⇩p a"
using setops⇩l⇩s⇩s⇩t⇩p_subst[OF assms] setops⇩l⇩s⇩s⇩t⇩pD(1) unfolding case_prod_unfold
by (metis (mono_tags, lifting) image_cong)
lemma setops⇩l⇩s⇩s⇩t_subst:
assumes "bvars⇩l⇩s⇩s⇩t S ∩ subst_domain θ = {}"
shows "setops⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t θ) = (λp. (fst p,snd p ⋅⇩p θ)) ` setops⇩l⇩s⇩s⇩t S"
using assms
proof (induction S)
case (Cons a S)
have "bvars⇩l⇩s⇩s⇩t S ∩ subst_domain θ = {}" and *: "set (bvars⇩s⇩s⇩t⇩p (snd a)) ∩ subst_domain θ = {}"
using Cons.prems by auto
hence IH: "setops⇩l⇩s⇩s⇩t (S ⋅⇩l⇩s⇩s⇩t θ) = (λp. (fst p,snd p ⋅⇩p θ)) ` setops⇩l⇩s⇩s⇩t S"
using Cons.IH by auto
show ?case
using setops⇩l⇩s⇩s⇩t⇩p_subst'[OF *] IH
unfolding setops⇩l⇩s⇩s⇩t_def case_prod_unfold subst_lsst_cons
by auto
qed (simp add: setops⇩s⇩s⇩t_def)
lemma setops⇩l⇩s⇩s⇩t⇩p_in_subst:
assumes p: "p ∈ setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p δ)"
shows "∃q ∈ setops⇩l⇩s⇩s⇩t⇩p a. fst p = fst q ∧ snd p = snd q ⋅⇩p rm_vars (set (bvars⇩s⇩s⇩t⇩p (snd a))) δ"
(is "∃q ∈ setops⇩l⇩s⇩s⇩t⇩p a. ?P q")
proof -
obtain l b where a: "a = (l,b)" by (metis surj_pair)
show ?thesis
proof (cases b)
case (NegChecks X F F')
hence "p ∈ (λ(t, s). (l, t ⋅ rm_vars (set X) δ, s ⋅ rm_vars (set X) δ)) ` set F'"
using p a setops⇩l⇩s⇩s⇩t⇩p_subst_cases(7)[of l X F F' δ] by blast
then obtain s t where st:
"(t,s) ∈ set F'" "p = (l, t ⋅ rm_vars (set X) δ, s ⋅ rm_vars (set X) δ)"
by auto
hence "(l,t,s) ∈ setops⇩l⇩s⇩s⇩t⇩p a" "fst p = fst (l,t,s)"
"snd p = snd (l,t,s) ⋅⇩p rm_vars (set X) δ"
using a NegChecks by fastforce+
moreover have "bvars⇩s⇩s⇩t⇩p (snd a) = X" using NegChecks a by auto
ultimately show ?thesis by blast
qed (use p a in auto)
qed
lemma setops⇩l⇩s⇩s⇩t_in_subst:
assumes "p ∈ setops⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
shows "∃q ∈ setops⇩l⇩s⇩s⇩t A. fst p = fst q ∧ (∃X ⊆ bvars⇩l⇩s⇩s⇩t A. snd p = snd q ⋅⇩p rm_vars X δ)"
(is "∃q ∈ setops⇩l⇩s⇩s⇩t A. ?P A q")
using assms
proof (induction A)
case (Cons a A)
note 0 = unlabel_Cons(2)[of a A] bvars⇩s⇩s⇩t_Cons[of "snd a" "unlabel A"]
show ?case
proof (cases "p ∈ setops⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)")
case False
hence "p ∈ setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p δ)"
using Cons.prems setops⇩l⇩s⇩s⇩t_cons[of "a ⋅⇩l⇩s⇩s⇩t⇩p δ" "A ⋅⇩l⇩s⇩s⇩t δ"] subst_lsst_cons[of a A δ] by auto
moreover have "(set (bvars⇩s⇩s⇩t⇩p (snd a))) ⊆ bvars⇩l⇩s⇩s⇩t (a#A)" using 0 by simp
ultimately have "∃q ∈ setops⇩l⇩s⇩s⇩t⇩p a. ?P (a#A) q" using setops⇩l⇩s⇩s⇩t⇩p_in_subst[of p a δ] by blast
thus ?thesis by auto
qed (use Cons.IH 0 in auto)
qed simp
lemma setops⇩l⇩s⇩s⇩t_dual⇩l⇩s⇩s⇩t_eq:
"setops⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) = setops⇩l⇩s⇩s⇩t A"
proof (induction A)
case (Cons a A)
obtain l b where "a = (l,b)" by (metis surj_pair)
thus ?case using Cons unfolding setops⇩l⇩s⇩s⇩t_def dual⇩l⇩s⇩s⇩t_def by (cases b) auto
qed simp
end
Theory Stateful_Compositionality
section ‹Stateful Protocol Compositionality›
text ‹\label{Stateful-Compositionality}›
theory Stateful_Compositionality
imports Stateful_Typing Parallel_Compositionality Labeled_Stateful_Strands
begin
subsection ‹Small Lemmata›
lemma (in typed_model) wt_subst_sstp_vars_type_subset:
fixes a::"('fun,'var) stateful_strand_step"
assumes "wt⇩s⇩u⇩b⇩s⇩t δ"
and "∀t ∈ subst_range δ. fv t = {} ∨ (∃x. t = Var x)"
shows "Γ ` Var ` fv⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ) ⊆ Γ ` Var ` fv⇩s⇩s⇩t⇩p a" (is ?A)
and "Γ ` Var ` set (bvars⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ)) = Γ ` Var ` set (bvars⇩s⇩s⇩t⇩p a)" (is ?B)
and "Γ ` Var ` vars⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ) ⊆ Γ ` Var ` vars⇩s⇩s⇩t⇩p a" (is ?C)
proof -
show ?A
proof
fix τ assume τ: "τ ∈ Γ ` Var ` fv⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ)"
then obtain x where x: "x ∈ fv⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ)" "Γ (Var x) = τ" by moura
show "τ ∈ Γ ` Var ` fv⇩s⇩s⇩t⇩p a"
proof (cases "x ∈ fv⇩s⇩s⇩t⇩p a")
case False
hence "∃y ∈ fv⇩s⇩s⇩t⇩p a. δ y = Var x"
proof (cases a)
case (NegChecks X F G)
hence *: "x ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ)"
"x ∉ set X"
using fv⇩s⇩s⇩t⇩p_NegCheck(1)[of X "F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ" "G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ"]
fv⇩s⇩s⇩t⇩p_NegCheck(1)[of X F G] False x(1)
by fastforce+
obtain y where y: "y ∈ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G" "x ∈ fv (rm_vars (set X) δ y)"
using fv⇩p⇩a⇩i⇩r⇩s_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
fv⇩p⇩a⇩i⇩r⇩s_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
*(1)
by blast
have "fv (rm_vars (set X) δ z) = {} ∨ (∃u. rm_vars (set X) δ z = Var u)" for z
using assms(2) rm_vars_img_subset[of "set X" δ] by blast
hence "rm_vars (set X) δ y = Var x" using y(2) by fastforce
hence "∃y ∈ fv⇩s⇩s⇩t⇩p a. rm_vars (set X) δ y = Var x"
using y fv⇩s⇩s⇩t⇩p_NegCheck(1)[of X F G] NegChecks *(2) by fastforce
thus ?thesis by (metis (full_types) *(2) term.inject(1))
qed (use assms(2) x(1) subst_apply_img_var'[of x _ δ] in fastforce)+
then obtain y where y: "y ∈ fv⇩s⇩s⇩t⇩p a" "δ y = Var x" by moura
hence "Γ (Var y) = τ" using x(2) assms(1) by (simp add: wt⇩s⇩u⇩b⇩s⇩t_def)
thus ?thesis using y(1) by auto
qed (use x in auto)
qed
show ?B by (metis bvars⇩s⇩s⇩t⇩p_subst)
show ?C
proof
fix τ assume τ: "τ ∈ Γ ` Var ` vars⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ)"
then obtain x where x: "x ∈ vars⇩s⇩s⇩t⇩p (a ⋅⇩s⇩s⇩t⇩p δ)" "Γ (Var x) = τ" by moura
show "τ ∈ Γ ` Var ` vars⇩s⇩s⇩t⇩p a"
proof (cases "x ∈ vars⇩s⇩s⇩t⇩p a")
case False
hence "∃y ∈ vars⇩s⇩s⇩t⇩p a. δ y = Var x"
proof (cases a)
case (NegChecks X F G)
hence *: "x ∈ fv⇩p⇩a⇩i⇩r⇩s (F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ) ∪ fv⇩p⇩a⇩i⇩r⇩s (G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ)"
"x ∉ set X"
using vars⇩s⇩s⇩t⇩p_NegCheck[of X "F ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ" "G ⋅⇩p⇩a⇩i⇩r⇩s rm_vars (set X) δ"]
vars⇩s⇩s⇩t⇩p_NegCheck[of X F G] False x(1)
by (fastforce, blast)
obtain y where y: "y ∈ fv⇩p⇩a⇩i⇩r⇩s F ∪ fv⇩p⇩a⇩i⇩r⇩s G" "x ∈ fv (rm_vars (set X) δ y)"
using fv⇩p⇩a⇩i⇩r⇩s_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
fv⇩p⇩a⇩i⇩r⇩s_subst_obtain_var[of _ _ "rm_vars (set X) δ"]
*(1)
by blast
have "fv (rm_vars (set X) δ z) = {} ∨ (∃u. rm_vars (set X) δ z = Var u)" for z
using assms(2) rm_vars_img_subset[of "set X" δ] by blast
hence "rm_vars (set X) δ y = Var x" using y(2) by fastforce
hence "∃y ∈ vars⇩s⇩s⇩t⇩p a. rm_vars (set X) δ y = Var x"
using y vars⇩s⇩s⇩t⇩p_NegCheck[of X F G] NegChecks by blast
thus ?thesis by (metis (full_types) *(2) term.inject(1))
qed (use assms(2) x(1) subst_apply_img_var'[of x _ δ] in fastforce)+
then obtain y where y: "y ∈ vars⇩s⇩s⇩t⇩p a" "δ y = Var x" by moura
hence "Γ (Var y) = τ" using x(2) assms(1) by (simp add: wt⇩s⇩u⇩b⇩s⇩t_def)
thus ?thesis using y(1) by auto
qed (use x in auto)
qed
qed
lemma (in typed_model) wt_subst_lsst_vars_type_subset:
fixes A::"('fun,'var,'a) labeled_stateful_strand"
assumes "wt⇩s⇩u⇩b⇩s⇩t δ"
and "∀t ∈ subst_range δ. fv t = {} ∨ (∃x. t = Var x)"
shows "Γ ` Var ` fv⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ) ⊆ Γ ` Var ` fv⇩l⇩s⇩s⇩t A" (is ?A)
and "Γ ` Var ` bvars⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ) = Γ ` Var ` bvars⇩l⇩s⇩s⇩t A" (is ?B)
and "Γ ` Var ` vars⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ) ⊆ Γ ` Var ` vars⇩l⇩s⇩s⇩t A" (is ?C)
proof -
have "vars⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t δ) = vars⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) ∪ vars⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
"vars⇩l⇩s⇩s⇩t (a#A) = vars⇩s⇩s⇩t⇩p b ∪ vars⇩l⇩s⇩s⇩t A"
"fv⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t δ) = fv⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) ∪ fv⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
"fv⇩l⇩s⇩s⇩t (a#A) = fv⇩s⇩s⇩t⇩p b ∪ fv⇩l⇩s⇩s⇩t A"
"bvars⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t δ) = set (bvars⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ)) ∪ bvars⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
"bvars⇩l⇩s⇩s⇩t (a#A) = set (bvars⇩s⇩s⇩t⇩p b) ∪ bvars⇩l⇩s⇩s⇩t A"
when "a = (l,b)" for a l b and A::"('fun,'var,'a) labeled_stateful_strand"
using that unlabel_Cons(1)[of l b A] unlabel_subst[of "a#A" δ]
subst_lsst_cons[of a A δ] subst_sst_cons[of b "unlabel A" δ]
subst_apply_labeled_stateful_strand_step.simps(1)[of l b δ]
vars⇩s⇩s⇩t_unlabel_Cons[of l b A] vars⇩s⇩s⇩t_unlabel_Cons[of l "b ⋅⇩s⇩s⇩t⇩p δ" "A ⋅⇩l⇩s⇩s⇩t δ"]
fv⇩s⇩s⇩t_unlabel_Cons[of l b A] fv⇩s⇩s⇩t_unlabel_Cons[of l "b ⋅⇩s⇩s⇩t⇩p δ" "A ⋅⇩l⇩s⇩s⇩t δ"]
bvars⇩s⇩s⇩t_unlabel_Cons[of l b A] bvars⇩s⇩s⇩t_unlabel_Cons[of l "b ⋅⇩s⇩s⇩t⇩p δ" "A ⋅⇩l⇩s⇩s⇩t δ"]
by simp_all
hence *: "Γ ` Var ` vars⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t δ) =
Γ ` Var ` vars⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) ∪ Γ ` Var ` vars⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
"Γ ` Var ` vars⇩l⇩s⇩s⇩t (a#A) = Γ ` Var ` vars⇩s⇩s⇩t⇩p b ∪ Γ ` Var ` vars⇩l⇩s⇩s⇩t A"
"Γ ` Var ` fv⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t δ) =
Γ ` Var ` fv⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ) ∪ Γ ` Var ` fv⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
"Γ ` Var ` fv⇩l⇩s⇩s⇩t (a#A) = Γ ` Var ` fv⇩s⇩s⇩t⇩p b ∪ Γ ` Var ` fv⇩l⇩s⇩s⇩t A"
"Γ ` Var ` bvars⇩l⇩s⇩s⇩t (a#A ⋅⇩l⇩s⇩s⇩t δ) =
Γ ` Var ` set (bvars⇩s⇩s⇩t⇩p (b ⋅⇩s⇩s⇩t⇩p δ)) ∪ Γ ` Var ` bvars⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
"Γ ` Var ` bvars⇩l⇩s⇩s⇩t (a#A) = Γ ` Var ` set (bvars⇩s⇩s⇩t⇩p b) ∪ Γ ` Var ` bvars⇩l⇩s⇩s⇩t A"
when "a = (l,b)" for a l b and A::"('fun,'var,'a) labeled_stateful_strand"
using that by fast+
have "?A ∧ ?B ∧ ?C"
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
show ?case
using Cons.IH wt_subst_sstp_vars_type_subset[OF assms, of b] *[OF a, of A]
by (metis Un_mono)
qed simp
thus ?A ?B ?C by metis+
qed
lemma (in stateful_typed_model) fv_pair_fv⇩p⇩a⇩i⇩r⇩s_subset:
assumes "d ∈ set D"
shows "fv (pair (snd d)) ⊆ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
using assms unfolding pair_def by (induct D) (auto simp add: unlabel_def)
lemma (in stateful_typed_model) labeled_sat_ineq_lift:
assumes "⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←dbproj i D. d ∉ set Di]⟧⇩d ℐ"
(is "?R1 D")
and "∀(j,p) ∈ {(i,t,s)} ∪ set D ∪ set Di. ∀(k,q) ∈ {(i,t,s)} ∪ set D ∪ set Di.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k" (is "?R2 D")
shows "⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←D. d ∉ set Di]⟧⇩d ℐ"
using assms
proof (induction D)
case (Cons dl D)
obtain d l where dl: "dl = (l,d)" by (metis surj_pair)
have 1: "?R1 D"
proof (cases "i = l")
case True thus ?thesis using Cons.prems(1) dl by (cases "dl ∈ set Di") auto
next
case False thus ?thesis using Cons.prems(1) dl by auto
qed
have "set D ⊆ set (dl#D)" by auto
hence 2: "?R2 D" using Cons.prems(2) by blast
have "i ≠ l ∨ dl ∈ set Di ∨ ⟦M; [∀X⟨∨≠: [(pair (t,s), pair (snd dl))]⟩⇩s⇩t]⟧⇩d ℐ"
using Cons.prems(1) dl by (auto simp add: ineq_model_def)
moreover have "∃δ. Unifier δ (pair (t,s)) (pair d) ⟹ i = l"
using Cons.prems(2) dl by force
ultimately have 3: "dl ∈ set Di ∨ ⟦M; [∀X⟨∨≠: [(pair (t,s), pair (snd dl))]⟩⇩s⇩t]⟧⇩d ℐ"
using strand_sem_not_unif_is_sat_ineq[of "pair (t,s)" "pair d"] dl by fastforce
show ?case using Cons.IH[OF 1 2] 3 dl by auto
qed simp
lemma (in stateful_typed_model) labeled_sat_ineq_dbproj:
assumes "⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←D. d ∉ set Di]⟧⇩d ℐ"
(is "?P D")
shows "⟦M; map (λd. ∀X⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←dbproj i D. d ∉ set Di]⟧⇩d ℐ"
(is "?Q D")
using assms
proof (induction D)
case (Cons di D)
obtain d j where di: "di = (j,d)" by (metis surj_pair)
have "?P D" using Cons.prems by (cases "di ∈ set Di") auto
hence IH: "?Q D" by (metis Cons.IH)
show ?case using di IH
proof (cases "i = j ∧ di ∉ set Di")
case True
have 1: "⟦M; [∀X⟨∨≠: [(pair (t,s), pair (snd di))]⟩⇩s⇩t]⟧⇩d ℐ"
using Cons.prems True by auto
have 2: "dbproj i (di#D) = di#dbproj i D" using True dbproj_Cons(1) di by auto
show ?thesis using 1 2 IH by auto
qed auto
qed simp
lemma (in stateful_typed_model) labeled_sat_ineq_dbproj_sem_equiv:
assumes "∀(j,p) ∈ ((λ(t, s). (i, t, s)) ` set F') ∪ set D.
∀(k,q) ∈ ((λ(t, s). (i, t, s)) ` set F') ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k"
and "fv⇩p⇩a⇩i⇩r⇩s (map snd D) ∩ set X = {}"
shows "⟦M; map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd D))⟧⇩d ℐ ⟷
⟦M; map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))⟧⇩d ℐ"
proof -
let ?A = "set (map snd D) ⋅⇩p⇩s⇩e⇩t ℐ"
let ?B = "set (map snd (dbproj i D)) ⋅⇩p⇩s⇩e⇩t ℐ"
let ?C = "set (map snd D) - set (map snd (dbproj i D))"
let ?F = "(λ(t, s). (i, t, s)) ` set F'"
let ?P = "λδ. subst_domain δ = set X ∧ ground (subst_range δ)"
have 1: "∀(t, t') ∈ set (map snd D). (fv t ∪ fv t') ∩ set X = {}"
"∀(t, t') ∈ set (map snd (dbproj i D)). (fv t ∪ fv t') ∩ set X = {}"
using assms(2) dbproj_subset[of i D] unfolding unlabel_def by force+
have 2: "?B ⊆ ?A" by auto
have 3: "¬Unifier δ (pair f) (pair d)"
when f: "f ∈ set F'" and d: "d ∈ set (map snd D) - set (map snd (dbproj i D))"
for f d and δ::"('fun,'var) subst"
proof -
obtain k where k: "(k,d) ∈ set D - set (dbproj i D)"
using d by force
have "(i,f) ∈ ((λ(t, s). (i, t, s)) ` set F') ∪ set D"
"(k,d) ∈ ((λ(t, s). (i, t, s)) ` set F') ∪ set D"
using f k by auto
hence "i = k" when "Unifier δ (pair f) (pair d)" for δ
using assms(1) that by blast
moreover have "k ≠ i" using k d by simp
ultimately show ?thesis by metis
qed
have "f ⋅⇩p δ ≠ d ⋅⇩p δ"
when "f ∈ set F'" "d ∈ ?C" for f d and δ::"('fun,'var) subst"
by (metis fun_pair_eq_subst 3[OF that])
hence "f ⋅⇩p (δ ∘⇩s ℐ) ∉ ?C ⋅⇩p⇩s⇩e⇩t (δ ∘⇩s ℐ)"
when "f ∈ set F'" for f and δ::"('fun,'var) subst"
using that by blast
moreover have "?C ⋅⇩p⇩s⇩e⇩t δ ⋅⇩p⇩s⇩e⇩t ℐ = ?C ⋅⇩p⇩s⇩e⇩t ℐ"
when "?P δ" for δ
using assms(2) that pairs_substI[of δ "(set (map snd D) - set (map snd (dbproj i D)))"]
by blast
ultimately have 4: "f ⋅⇩p (δ ∘⇩s ℐ) ∉ ?C ⋅⇩p⇩s⇩e⇩t ℐ"
when "f ∈ set F'" "?P δ" for f and δ::"('fun,'var) subst"
by (metis that subst_pairs_compose)
{ fix f and δ::"('fun,'var) subst"
assume "f ∈ set F'" "?P δ"
hence "f ⋅⇩p (δ ∘⇩s ℐ) ∉ ?C ⋅⇩p⇩s⇩e⇩t ℐ" by (metis 4)
hence "f ⋅⇩p (δ ∘⇩s ℐ) ∉ ?A - ?B" by force
} hence 5: "∀f∈set F'. ∀δ. ?P δ ⟶ f ⋅⇩p (δ ∘⇩s ℐ) ∉ ?A - ?B" by metis
show ?thesis
using negchecks_model_db_subset[OF 2]
negchecks_model_db_supset[OF 2 5]
tr⇩p⇩a⇩i⇩r⇩s_sem_equiv[OF 1(1)]
tr⇩p⇩a⇩i⇩r⇩s_sem_equiv[OF 1(2)]
tr_NegChecks_constr_iff(1)
strand_sem_eq_defs(2)
by (metis (no_types, lifting))
qed
lemma (in stateful_typed_model) labeled_sat_eqs_list_all:
assumes "∀(j, p) ∈ {(i,t,s)} ∪ set D. ∀(k,q) ∈ {(i,t,s)} ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k" (is "?P D")
and "⟦M; map (λd. ⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t) D⟧⇩d ℐ" (is "?Q D")
shows "list_all (λd. fst d = i) D"
using assms
proof (induction D rule: List.rev_induct)
case (snoc di D)
obtain d j where di: "di = (j,d)" by (metis surj_pair)
have "pair (t,s) ⋅ ℐ = pair d ⋅ ℐ" using di snoc.prems(2) by auto
hence "∃δ. Unifier δ (pair (t,s)) (pair d)" by auto
hence 1: "i = j" using snoc.prems(1) di by fastforce
have "set D ⊆ set (D@[di])" by auto
hence 2: "?P D" using snoc.prems(1) by blast
have 3: "?Q D" using snoc.prems(2) by auto
show ?case using di 1 snoc.IH[OF 2 3] by simp
qed simp
lemma (in stateful_typed_model) labeled_sat_eqs_subseqs:
assumes "Di ∈ set (subseqs D)"
and "∀(j, p) ∈ {(i,t,s)} ∪ set D. ∀(k, q) ∈ {(i,t,s)} ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k" (is "?P D")
and "⟦M; map (λd. ⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t) Di⟧⇩d ℐ"
shows "Di ∈ set (subseqs (dbproj i D))"
proof -
have "set Di ⊆ set D" by (rule subseqs_subset[OF assms(1)])
hence "?P Di" using assms(2) by blast
thus ?thesis using labeled_sat_eqs_list_all[OF _ assms(3)] subseqs_mem_dbproj[OF assms(1)] by simp
qed
lemma (in stateful_typed_model) dual⇩l⇩s⇩s⇩t_tfr⇩s⇩s⇩t⇩p:
assumes "list_all tfr⇩s⇩s⇩t⇩p (unlabel S)"
shows "list_all tfr⇩s⇩s⇩t⇩p (unlabel (dual⇩l⇩s⇩s⇩t S))"
using assms
proof (induction S)
case (Cons a S)
have prems: "tfr⇩s⇩s⇩t⇩p (snd a)" "list_all tfr⇩s⇩s⇩t⇩p (unlabel S)"
using Cons.prems unlabel_Cons(2)[of a S] by simp_all
hence IH: "list_all tfr⇩s⇩s⇩t⇩p (unlabel (dual⇩l⇩s⇩s⇩t S))" by (metis Cons.IH)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
with Cons show ?case
proof (cases b)
case (Equality c t t')
hence "dual⇩l⇩s⇩s⇩t (a#S) = a#dual⇩l⇩s⇩s⇩t S" by (metis dual⇩l⇩s⇩s⇩t_Cons(3) a)
thus ?thesis using a IH prems by fastforce
next
case (NegChecks X F G)
hence "dual⇩l⇩s⇩s⇩t (a#S) = a#dual⇩l⇩s⇩s⇩t S" by (metis dual⇩l⇩s⇩s⇩t_Cons(7) a)
thus ?thesis using a IH prems by fastforce
qed auto
qed simp
lemma (in stateful_typed_model) setops⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq:
"setops⇩s⇩s⇩t (unlabel (dual⇩l⇩s⇩s⇩t A)) = setops⇩s⇩s⇩t (unlabel A)"
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
thus ?case using Cons.IH by (cases b) (simp_all add: setops⇩s⇩s⇩t_def)
qed simp
subsection ‹Locale Setup and Definitions›
locale labeled_stateful_typed_model =
stateful_typed_model arity public Ana Γ Pair
+ labeled_typed_model arity public Ana Γ label_witness1 label_witness2
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,'var) term ⇒ (('fun,'var) term list × ('fun,'var) term list)"
and Γ::"('fun,'var) term ⇒ ('fun,'atom::finite) term_type"
and Pair::"'fun"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
begin
definition lpair where
"lpair lp ≡ case lp of (i,p) ⇒ (i,pair p)"
lemma setops⇩l⇩s⇩s⇩t⇩p_pair_image[simp]:
"lpair ` (setops⇩l⇩s⇩s⇩t⇩p (i,send⟨t⟩)) = {}"
"lpair ` (setops⇩l⇩s⇩s⇩t⇩p (i,receive⟨t⟩)) = {}"
"lpair ` (setops⇩l⇩s⇩s⇩t⇩p (i,⟨ac: t ≐ t'⟩)) = {}"
"lpair ` (setops⇩l⇩s⇩s⇩t⇩p (i,insert⟨t,s⟩)) = {(i, pair (t,s))}"
"lpair ` (setops⇩l⇩s⇩s⇩t⇩p (i,delete⟨t,s⟩)) = {(i, pair (t,s))}"
"lpair ` (setops⇩l⇩s⇩s⇩t⇩p (i,⟨ac: t ∈ s⟩)) = {(i, pair (t,s))}"
"lpair ` (setops⇩l⇩s⇩s⇩t⇩p (i,∀X⟨∨≠: F ∨∉: F'⟩)) = ((λ(t,s). (i, pair (t,s))) ` set F')"
unfolding lpair_def by force+
definition par_comp⇩l⇩s⇩s⇩t where
"par_comp⇩l⇩s⇩s⇩t (𝒜::('fun,'var,'lbl) labeled_stateful_strand) (Secrets::('fun,'var) terms) ≡
(∀l1 l2. l1 ≠ l2 ⟶
GSMP_disjoint (trms⇩s⇩s⇩t (proj_unl l1 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l1 𝒜))
(trms⇩s⇩s⇩t (proj_unl l2 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l2 𝒜)) Secrets) ∧
ground Secrets ∧ (∀s ∈ Secrets. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ Secrets) ∧
(∀(i,p) ∈ setops⇩l⇩s⇩s⇩t 𝒜. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t 𝒜.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j)"
definition declassified⇩l⇩s⇩s⇩t where
"declassified⇩l⇩s⇩s⇩t 𝒜 ℐ ≡ {t. ⟨⋆, receive⟨t⟩⟩ ∈ set 𝒜} ⋅⇩s⇩e⇩t ℐ"
definition strand_leaks⇩l⇩s⇩s⇩t ("_ leaks _ under _") where
"(𝒜::('fun,'var,'lbl) labeled_stateful_strand) leaks Secrets under ℐ ≡
(∃t ∈ Secrets - declassified⇩l⇩s⇩s⇩t 𝒜 ℐ. ∃n. ℐ ⊨⇩s (proj_unl n 𝒜@[send⟨t⟩]))"
definition typing_cond⇩s⇩s⇩t where
"typing_cond⇩s⇩s⇩t 𝒜 ≡ wf⇩s⇩s⇩t 𝒜 ∧ wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t 𝒜) ∧ tfr⇩s⇩s⇩t 𝒜"
type_synonym ('a,'b,'c) labeleddbstate = "('c strand_label × (('a,'b) term × ('a,'b) term)) set"
type_synonym ('a,'b,'c) labeleddbstatelist = "('c strand_label × (('a,'b) term × ('a,'b) term)) list"
text ‹
For proving the compositionality theorem for stateful constraints the idea is to first define a
variant of the reduction technique that was used to establish the stateful typing result. This
variant performs database-state projections, and it allows us to reduce the compositionality
problem for stateful constraints to ordinary constraints.
›
fun tr⇩p⇩c::
"('fun,'var,'lbl) labeled_stateful_strand ⇒ ('fun,'var,'lbl) labeleddbstatelist
⇒ ('fun,'var,'lbl) labeled_strand list"
where
"tr⇩p⇩c [] D = [[]]"
| "tr⇩p⇩c ((i,send⟨t⟩)#A) D = map ((#) (i,send⟨t⟩⇩s⇩t)) (tr⇩p⇩c A D)"
| "tr⇩p⇩c ((i,receive⟨t⟩)#A) D = map ((#) (i,receive⟨t⟩⇩s⇩t)) (tr⇩p⇩c A D)"
| "tr⇩p⇩c ((i,⟨ac: t ≐ t'⟩)#A) D = map ((#) (i,⟨ac: t ≐ t'⟩⇩s⇩t)) (tr⇩p⇩c A D)"
| "tr⇩p⇩c ((i,insert⟨t,s⟩)#A) D = tr⇩p⇩c A (List.insert (i,(t,s)) D)"
| "tr⇩p⇩c ((i,delete⟨t,s⟩)#A) D = (
concat (map (λDi. map (λB. (map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t))
[d←dbproj i D. d ∉ set Di])@B)
(tr⇩p⇩c A [d←D. d ∉ set Di]))
(subseqs (dbproj i D))))"
| "tr⇩p⇩c ((i,⟨ac: t ∈ s⟩)#A) D =
concat (map (λB. map (λd. (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#B) (dbproj i D)) (tr⇩p⇩c A D))"
| "tr⇩p⇩c ((i,∀X⟨∨≠: F ∨∉: F' ⟩)#A) D =
map ((@) (map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D))))) (tr⇩p⇩c A D)"
subsection ‹Small Lemmata›
lemma par_comp⇩l⇩s⇩s⇩t_nil:
assumes "ground Sec" "∀s ∈ Sec. ∀s'∈subterms s. {} ⊢⇩c s' ∨ s' ∈ Sec"
shows "par_comp⇩l⇩s⇩s⇩t [] Sec"
using assms unfolding par_comp⇩l⇩s⇩s⇩t_def by simp
lemma par_comp⇩l⇩s⇩s⇩t_subset:
assumes A: "par_comp⇩l⇩s⇩s⇩t A Sec"
and BA: "set B ⊆ set A"
shows "par_comp⇩l⇩s⇩s⇩t B Sec"
proof -
let ?L = "λn A. trms⇩s⇩s⇩t (proj_unl n A) ∪ pair ` setops⇩s⇩s⇩t (proj_unl n A)"
have "?L n B ⊆ ?L n A" for n
using trms⇩s⇩s⇩t_mono[OF proj_set_mono(2)[OF BA]] setops⇩s⇩s⇩t_mono[OF proj_set_mono(2)[OF BA]]
by blast
hence "GSMP_disjoint (?L m B) (?L n B) Sec" when nm: "m ≠ n" for n m::'lbl
using GSMP_disjoint_subset[of "?L m A" "?L n A" Sec "?L m B" "?L n B"] A nm
unfolding par_comp⇩l⇩s⇩s⇩t_def by simp
thus "par_comp⇩l⇩s⇩s⇩t B Sec"
using A setops⇩l⇩s⇩s⇩t_mono[OF BA]
unfolding par_comp⇩l⇩s⇩s⇩t_def by blast
qed
lemma par_comp⇩l⇩s⇩s⇩t_split:
assumes "par_comp⇩l⇩s⇩s⇩t (A@B) Sec"
shows "par_comp⇩l⇩s⇩s⇩t A Sec" "par_comp⇩l⇩s⇩s⇩t B Sec"
using par_comp⇩l⇩s⇩s⇩t_subset[OF assms] by simp_all
lemma par_comp⇩l⇩s⇩s⇩t_proj:
assumes "par_comp⇩l⇩s⇩s⇩t A Sec"
shows "par_comp⇩l⇩s⇩s⇩t (proj n A) Sec"
using par_comp⇩l⇩s⇩s⇩t_subset[OF assms] by simp
lemma par_comp⇩l⇩s⇩s⇩t_dual⇩l⇩s⇩s⇩t:
assumes A: "par_comp⇩l⇩s⇩s⇩t A S"
shows "par_comp⇩l⇩s⇩s⇩t (dual⇩l⇩s⇩s⇩t A) S"
proof (unfold par_comp⇩l⇩s⇩s⇩t_def case_prod_unfold; intro conjI)
show "ground S" "∀s ∈ S. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ S"
using A unfolding par_comp⇩l⇩s⇩s⇩t_def by fast+
let ?M = "λl B. (trms⇩l⇩s⇩s⇩t (proj l B) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l B))"
let ?P = "λB. ∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (?M l1 B) (?M l2 B) S"
let ?Q = "λB. ∀p ∈ setops⇩l⇩s⇩s⇩t B. ∀q ∈ setops⇩l⇩s⇩s⇩t B.
(∃δ. Unifier δ (pair (snd p)) (pair (snd q))) ⟶ fst p = fst q"
have "?P A" "?Q A" using A unfolding par_comp⇩l⇩s⇩s⇩t_def case_prod_unfold by blast+
thus "?P (dual⇩l⇩s⇩s⇩t A)" "?Q (dual⇩l⇩s⇩s⇩t A)"
by (metis setops⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq trms⇩s⇩s⇩t_unlabel_dual⇩l⇩s⇩s⇩t_eq proj_dual⇩l⇩s⇩s⇩t,
metis setops⇩l⇩s⇩s⇩t_dual⇩l⇩s⇩s⇩t_eq)
qed
lemma par_comp⇩l⇩s⇩s⇩t_subst:
assumes A: "par_comp⇩l⇩s⇩s⇩t A S"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)" "subst_domain δ ∩ bvars⇩l⇩s⇩s⇩t A = {}"
shows "par_comp⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ) S"
proof (unfold par_comp⇩l⇩s⇩s⇩t_def case_prod_unfold; intro conjI)
show "ground S" "∀s ∈ S. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ S"
using A unfolding par_comp⇩l⇩s⇩s⇩t_def by fast+
let ?N = "λl B. trms⇩l⇩s⇩s⇩t (proj l B) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l B)"
define M where "M ≡ λl (B::('fun,'var,'lbl) labeled_stateful_strand). ?N l B"
let ?P = "λp q. ∃δ. Unifier δ (pair (snd p)) (pair (snd q))"
let ?Q = "λB. ∀p ∈ setops⇩l⇩s⇩s⇩t B. ∀q ∈ setops⇩l⇩s⇩s⇩t B. ?P p q ⟶ fst p = fst q"
let ?R = "λB. ∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (?N l1 B) (?N l2 B) S"
have d: "bvars⇩l⇩s⇩s⇩t (proj l A) ∩ subst_domain δ = {}" for l
using δ(3) unfolding proj_def bvars⇩s⇩s⇩t_def unlabel_def by auto
have "GSMP_disjoint (M l1 A) (M l2 A) S" when l: "l1 ≠ l2" for l1 l2
using l A unfolding par_comp⇩l⇩s⇩s⇩t_def M_def by presburger
moreover have "M l (A ⋅⇩l⇩s⇩s⇩t δ) = (M l A) ⋅⇩s⇩e⇩t δ" for l
using fun_pair_subst_set[of δ "setops⇩s⇩s⇩t (proj_unl l A)", symmetric]
trms⇩s⇩s⇩t_subst[OF d[of l]] setops⇩s⇩s⇩t_subst[OF d[of l]] proj_subst[of l A δ]
unfolding M_def unlabel_subst by auto
ultimately have "GSMP_disjoint (M l1 (A ⋅⇩l⇩s⇩s⇩t δ)) (M l2 (A ⋅⇩l⇩s⇩s⇩t δ)) S" when l: "l1 ≠ l2" for l1 l2
using l GSMP_wt_subst_subset[OF _ δ(1,2), of _ "M l1 A"]
GSMP_wt_subst_subset[OF _ δ(1,2), of _ "M l2 A"]
unfolding GSMP_disjoint_def by fastforce
thus "?R (A ⋅⇩l⇩s⇩s⇩t δ)" unfolding M_def by blast
have "?Q A" using A unfolding par_comp⇩l⇩s⇩s⇩t_def by force
thus "?Q (A ⋅⇩l⇩s⇩s⇩t δ)" using δ(3)
proof (induction A)
case (Cons a A)
obtain l b where a: "a = (l,b)" by (metis surj_pair)
have 0: "bvars⇩l⇩s⇩s⇩t (a#A) = set (bvars⇩s⇩s⇩t⇩p (snd a)) ∪ bvars⇩l⇩s⇩s⇩t A"
unfolding bvars⇩s⇩s⇩t_def unlabel_def by simp
have "?Q A" "subst_domain δ ∩ bvars⇩l⇩s⇩s⇩t A = {}"
using Cons.prems 0 unfolding setops⇩l⇩s⇩s⇩t_def by auto
hence IH: "?Q (A ⋅⇩l⇩s⇩s⇩t δ)" using Cons.IH unfolding setops⇩l⇩s⇩s⇩t_def by blast
have 1: "fst p = fst q"
when p: "p ∈ setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p δ)"
and q: "q ∈ setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p δ)"
and pq: "?P p q"
for p q
using a p q pq by (cases b) auto
have 2: "fst p = fst q"
when p: "p ∈ setops⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
and q: "q ∈ setops⇩l⇩s⇩s⇩t⇩p (a ⋅⇩l⇩s⇩s⇩t⇩p δ)"
and pq: "?P p q"
for p q
proof -
obtain p' X where p':
"p' ∈ setops⇩l⇩s⇩s⇩t A" "fst p = fst p'"
"X ⊆ bvars⇩l⇩s⇩s⇩t (a#A)" "snd p = snd p' ⋅⇩p rm_vars X δ"
using setops⇩l⇩s⇩s⇩t_in_subst[OF p] 0 by blast
obtain q' Y where q':
"q' ∈ setops⇩l⇩s⇩s⇩t⇩p a" "fst q = fst q'"
"Y ⊆ bvars⇩l⇩s⇩s⇩t (a#A)" "snd q = snd q' ⋅⇩p rm_vars Y δ"
using setops⇩l⇩s⇩s⇩t⇩p_in_subst[OF q] 0 by blast
have "pair (snd p) = pair (snd p') ⋅ δ"
"pair (snd q) = pair (snd q') ⋅ δ"
using fun_pair_subst[of "snd p'" "rm_vars X δ"] fun_pair_subst[of "snd q'" "rm_vars Y δ"]
p'(3,4) q'(3,4) Cons.prems(2) rm_vars_apply'[of δ X] rm_vars_apply'[of δ Y]
by fastforce+
hence "∃δ. Unifier δ (pair (snd p')) (pair (snd q'))"
using pq Unifier_comp' by metis
thus ?thesis using Cons.prems p'(1,2) q'(1,2) by simp
qed
show ?case by (metis 1 2 IH Un_iff setops⇩l⇩s⇩s⇩t_cons subst_lsst_cons)
qed simp
qed
lemma wf_pair_negchecks_map':
assumes "wf⇩s⇩t X (unlabel A)"
shows "wf⇩s⇩t X (unlabel (map (λG. (i,∀Y⟨∨≠: (F@G)⟩⇩s⇩t)) M@A))"
using assms by (induct M) auto
lemma wf_pair_eqs_ineqs_map':
fixes A::"('fun,'var,'lbl) labeled_strand"
assumes "wf⇩s⇩t X (unlabel A)"
"Di ∈ set (subseqs (dbproj i D))"
"fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X"
shows "wf⇩s⇩t X (unlabel (
(map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←dbproj i D. d ∉ set Di])@A))"
proof -
let ?f = "[d←dbproj i D. d ∉ set Di]"
define c1 where c1: "c1 = map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di"
define c2 where c2: "c2 = map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) ?f"
define c3 where c3: "c3 = map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) (unlabel Di)"
define c4 where c4: "c4 = map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) (unlabel ?f)"
have ci_eqs: "c3 = unlabel c1" "c4 = unlabel c2" unfolding c1 c2 c3 c4 unlabel_def by auto
have 1: "wf⇩s⇩t X (unlabel (c2@A))"
using wf_fun_pair_ineqs_map[OF assms(1)] ci_eqs(2) unlabel_append[of c2 A] c4
by metis
have 2: "fv⇩p⇩a⇩i⇩r⇩s (unlabel Di) ⊆ X"
using assms(3) subseqs_set_subset(1)[OF assms(2)]
unfolding unlabel_def
by fastforce
{ fix B::"('fun,'var) strand" assume "wf⇩s⇩t X B"
hence "wf⇩s⇩t X (unlabel c1@B)" using 2 unfolding c1 unlabel_def by (induct Di) auto
} thus ?thesis using 1 unfolding c1 c2 unlabel_def by simp
qed
lemma trms⇩s⇩s⇩t_setops⇩s⇩s⇩t_wt_instance_ex:
defines "M ≡ λA. trms⇩l⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t (unlabel A)"
assumes B: "∀b ∈ set B. ∃a ∈ set A. ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "∀t ∈ M B. ∃s ∈ M A. ∃δ. t = s ⋅ δ ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
proof
let ?P = "λδ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
fix t assume "t ∈ M B"
then obtain b where b: "b ∈ set B" "t ∈ trms⇩s⇩s⇩t⇩p (snd b) ∪ pair ` setops⇩s⇩s⇩t⇩p (snd b)"
unfolding M_def unfolding unlabel_def trms⇩s⇩s⇩t_def setops⇩s⇩s⇩t_def by auto
then obtain a δ where a: "a ∈ set A" "b = a ⋅⇩l⇩s⇩s⇩t⇩p δ" and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using B by meson
note δ' = wt_subst_rm_vars[OF δ(1)] wf_trms_subst_rm_vars'[OF δ(2)]
have "t ∈ M (A ⋅⇩l⇩s⇩s⇩t δ)"
using b(2) a
unfolding M_def subst_apply_labeled_stateful_strand_def unlabel_def trms⇩s⇩s⇩t_def setops⇩s⇩s⇩t_def
by auto
moreover have "∃s ∈ M A. ∃δ. t = s ⋅ δ ∧ ?P δ" when "t ∈ trms⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
using trms⇩s⇩s⇩t_unlabel_subst'[OF that] δ' unfolding M_def by blast
moreover have "∃s ∈ M A. ∃δ. t = s ⋅ δ ∧ ?P δ" when t: "t ∈ pair ` setops⇩s⇩s⇩t (unlabel A ⋅⇩s⇩s⇩t δ)"
proof -
obtain p where p: "p ∈ setops⇩s⇩s⇩t (unlabel A ⋅⇩s⇩s⇩t δ)" "t = pair p" using t by blast
then obtain q X where q: "q ∈ setops⇩s⇩s⇩t (unlabel A)" "p = q ⋅⇩p rm_vars (set X) δ"
using setops⇩s⇩s⇩t_subst'[OF p(1)] by blast
hence "t = pair q ⋅ rm_vars (set X) δ"
using fun_pair_subst[of q "rm_vars (set X) δ"] p(2) by presburger
thus ?thesis using δ'[of "set X"] q(1) unfolding M_def by blast
qed
ultimately show "∃s ∈ M A. ∃δ. t = s ⋅ δ ∧ ?P δ" unfolding M_def unlabel_subst by fast
qed
lemma setops⇩l⇩s⇩s⇩t_wt_instance_ex:
assumes B: "∀b ∈ set B. ∃a ∈ set A. ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
shows "∀p ∈ setops⇩l⇩s⇩s⇩t B. ∃q ∈ setops⇩l⇩s⇩s⇩t A. ∃δ.
fst p = fst q ∧ snd p = snd q ⋅⇩p δ ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
proof
let ?P = "λδ. wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
fix p assume "p ∈ setops⇩l⇩s⇩s⇩t B"
then obtain b where b: "b ∈ set B" "p ∈ setops⇩l⇩s⇩s⇩t⇩p b" unfolding setops⇩l⇩s⇩s⇩t_def by blast
then obtain a δ where a: "a ∈ set A" "b = a ⋅⇩l⇩s⇩s⇩t⇩p δ" and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
using B by meson
hence p: "p ∈ setops⇩l⇩s⇩s⇩t (A ⋅⇩l⇩s⇩s⇩t δ)"
using b(2) unfolding setops⇩l⇩s⇩s⇩t_def subst_apply_labeled_stateful_strand_def by auto
obtain X q where q:
"q ∈ setops⇩l⇩s⇩s⇩t A" "fst p = fst q" "snd p = snd q ⋅⇩p rm_vars X δ"
using setops⇩l⇩s⇩s⇩t_in_subst[OF p] by blast
show "∃q ∈ setops⇩l⇩s⇩s⇩t A. ∃δ. fst p = fst q ∧ snd p = snd q ⋅⇩p δ ∧ ?P δ"
using q wt_subst_rm_vars[OF δ(1)] wf_trms_subst_rm_vars'[OF δ(2)] by blast
qed
subsection ‹Lemmata: Properties of the Constraint Translation Function›
lemma tr_par_labeled_rcv_iff:
"B ∈ set (tr⇩p⇩c A D) ⟹ (i, receive⟨t⟩⇩s⇩t) ∈ set B ⟷ (i, receive⟨t⟩) ∈ set A"
by (induct A D arbitrary: B rule: tr⇩p⇩c.induct) auto
lemma tr_par_declassified_eq:
"B ∈ set (tr⇩p⇩c A D) ⟹ declassified⇩l⇩s⇩t B I = declassified⇩l⇩s⇩s⇩t A I"
using tr_par_labeled_rcv_iff unfolding declassified⇩l⇩s⇩t_def declassified⇩l⇩s⇩s⇩t_def by simp
lemma tr_par_ik_eq:
assumes "B ∈ set (tr⇩p⇩c A D)"
shows "ik⇩s⇩t (unlabel B) = ik⇩s⇩s⇩t (unlabel A)"
proof -
have "{t. ∃i. (i, receive⟨t⟩⇩s⇩t) ∈ set B} = {t. ∃i. (i, receive⟨t⟩) ∈ set A}"
using tr_par_labeled_rcv_iff[OF assms] by simp
moreover have
"⋀C. {t. ∃i. (i, receive⟨t⟩⇩s⇩t) ∈ set C} = {t. receive⟨t⟩⇩s⇩t ∈ set (unlabel C)}"
"⋀C. {t. ∃i. (i, receive⟨t⟩) ∈ set C} = {t. receive⟨t⟩ ∈ set (unlabel C)}"
unfolding unlabel_def by force+
ultimately show ?thesis by (metis ik⇩s⇩s⇩t_def ik⇩s⇩t_is_rcv_set)
qed
lemma tr_par_deduct_iff:
assumes "B ∈ set (tr⇩p⇩c A D)"
shows "ik⇩s⇩t (unlabel B) ⋅⇩s⇩e⇩t I ⊢ t ⟷ ik⇩s⇩s⇩t (unlabel A) ⋅⇩s⇩e⇩t I ⊢ t"
using tr_par_ik_eq[OF assms] by metis
lemma tr_par_vars_subset:
assumes "A' ∈ set (tr⇩p⇩c A D)"
shows "fv⇩l⇩s⇩t A' ⊆ fv⇩s⇩s⇩t (unlabel A) ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)" (is ?P)
and "bvars⇩l⇩s⇩t A' ⊆ bvars⇩s⇩s⇩t (unlabel A)" (is ?Q)
proof -
show ?P using assms
proof (induction "unlabel A" arbitrary: A A' D rule: strand_sem_stateful_induct)
case (ConsIn A' D ac t s AA A A')
then obtain i B where iB: "A = (i,⟨ac: t ∈ s⟩)#B" "AA = unlabel B"
unfolding unlabel_def by moura
then obtain A'' d where *:
"d ∈ set (dbproj i D)"
"A' = (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#A''"
"A'' ∈ set (tr⇩p⇩c B D)"
using ConsIn.prems(1) by moura
hence "fv⇩l⇩s⇩t A'' ⊆ fv⇩s⇩s⇩t (unlabel B) ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
"fv (pair (snd d)) ⊆ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
apply (metis ConsIn.hyps(1)[OF iB(2)])
using fv⇩p⇩a⇩i⇩r⇩s_mono[OF dbproj_subset[of i D]]
fv_pair_fv⇩p⇩a⇩i⇩r⇩s_subset[OF *(1)]
by blast
thus ?case using * iB unfolding pair_def by auto
next
case (ConsDel A' D t s AA A A')
then obtain i B where iB: "A = (i,delete⟨t,s⟩)#B" "AA = unlabel B"
unfolding unlabel_def by moura
define fltD1 where "fltD1 = (λDi. filter (λd. d ∉ set Di) D)"
define fltD2 where "fltD2 = (λDi. filter (λd. d ∉ set Di) (dbproj i D))"
define constr where "constr =
(λDi. (map (λd. (i, ⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i, ∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) (fltD2 Di)))"
from iB obtain A'' Di where *:
"Di ∈ set (subseqs (dbproj i D))" "A' = (constr Di)@A''" "A'' ∈ set (tr⇩p⇩c B (fltD1 Di))"
using ConsDel.prems(1) unfolding constr_def fltD1_def fltD2_def by moura
hence "fv⇩l⇩s⇩t A'' ⊆ fv⇩s⇩s⇩t AA ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel (fltD1 Di))"
unfolding constr_def fltD1_def by (metis ConsDel.hyps(1) iB(2))
hence 1: "fv⇩l⇩s⇩t A'' ⊆ fv⇩s⇩s⇩t AA ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
using fv⇩p⇩a⇩i⇩r⇩s_mono[of "unlabel (fltD1 Di)" "unlabel D"]
unfolding unlabel_def fltD1_def by force
have 2: "fv⇩p⇩a⇩i⇩r⇩s (unlabel Di) ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel (fltD1 Di)) ⊆ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
using subseqs_set_subset(1)[OF *(1)]
unfolding fltD1_def unlabel_def
by auto
have 5: "fv⇩l⇩s⇩t A' = fv⇩l⇩s⇩t (constr Di) ∪ fv⇩l⇩s⇩t A''" using * unfolding unlabel_def by force
have "fv⇩l⇩s⇩t (constr Di) ⊆ fv t ∪ fv s ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel Di) ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel (fltD1 Di))"
unfolding unlabel_def constr_def fltD1_def fltD2_def pair_def by auto
hence 3: "fv⇩l⇩s⇩t (constr Di) ⊆ fv t ∪ fv s ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)" using 2 by blast
have 4: "fv⇩s⇩s⇩t (unlabel A) = fv t ∪ fv s ∪ fv⇩s⇩s⇩t AA" using iB by auto
have "fv⇩s⇩t (unlabel A') ⊆ fv⇩s⇩s⇩t (unlabel A) ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)" using 1 3 4 5 by blast
thus ?case by metis
next
case (ConsNegChecks A' D X F F' AA A A')
then obtain i B where iB: "A = (i,NegChecks X F F')#B" "AA = unlabel B"
unfolding unlabel_def by moura
define D' where "D' ≡ ⋃(fv⇩p⇩a⇩i⇩r⇩s ` set (tr⇩p⇩a⇩i⇩r⇩s F' (unlabel (dbproj i D))))"
define constr where "constr = map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
from iB obtain A'' where *: "A'' ∈ set (tr⇩p⇩c B D)" "A' = constr@A''"
using ConsNegChecks.prems(1) unfolding constr_def by moura
hence "fv⇩l⇩s⇩t A'' ⊆ fv⇩s⇩s⇩t AA ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
by (metis ConsNegChecks.hyps(1) iB(2))
hence **: "fv⇩l⇩s⇩t A'' ⊆ fv⇩s⇩s⇩t AA ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)" by auto
have 1: "fv⇩l⇩s⇩t constr ⊆ (D' ∪ fv⇩p⇩a⇩i⇩r⇩s F) - set X"
unfolding D'_def constr_def unlabel_def by auto
have "set (unlabel (dbproj i D)) ⊆ set (unlabel D)" unfolding unlabel_def by auto
hence 2: "D' ⊆ fv⇩p⇩a⇩i⇩r⇩s F' ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
using tr⇩p⇩a⇩i⇩r⇩s_vars_subset'[of F' "unlabel (dbproj i D)"] fv⇩p⇩a⇩i⇩r⇩s_mono
unfolding D'_def by blast
have 3: "fv⇩l⇩s⇩t A' ⊆ ((fv⇩p⇩a⇩i⇩r⇩s F' ∪ fv⇩p⇩a⇩i⇩r⇩s F) - set X) ∪ fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ∪ fv⇩l⇩s⇩t A''"
using 1 2 *(2) unfolding unlabel_def by fastforce
have 4: "fv⇩s⇩s⇩t AA ⊆ fv⇩s⇩s⇩t (unlabel A)" by (metis ConsNegChecks.hyps(2) fv⇩s⇩s⇩t_cons_subset)
have 5: "fv⇩p⇩a⇩i⇩r⇩s F' ∪ fv⇩p⇩a⇩i⇩r⇩s F - set X ⊆ fv⇩s⇩s⇩t (unlabel A)"
using ConsNegChecks.hyps(2) unfolding unlabel_def by force
show ?case using ** 3 4 5 by blast
qed (fastforce simp add: unlabel_def)+
show ?Q using assms
apply (induct "unlabel A" arbitrary: A A' D rule: strand_sem_stateful_induct)
by (fastforce simp add: unlabel_def)+
qed
lemma tr_par_vars_disj:
assumes "A' ∈ set (tr⇩p⇩c A D)" "fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
and "fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
shows "fv⇩l⇩s⇩t A' ∩ bvars⇩l⇩s⇩t A' = {}"
using assms tr_par_vars_subset by fast
lemma tr_par_trms_subset:
assumes "A' ∈ set (tr⇩p⇩c A D)"
shows "trms⇩l⇩s⇩t A' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D"
using assms
proof (induction A D arbitrary: A' rule: tr⇩p⇩c.induct)
case 1 thus ?case by simp
next
case (2 i t A D)
then obtain A'' where A'': "A' = (i,send⟨t⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)" by moura
hence "trms⇩l⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D"
by (metis "2.IH")
thus ?case using A'' by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (3 i t A D)
then obtain A'' where A'': "A' = (i,receive⟨t⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)"
by moura
hence "trms⇩l⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D"
by (metis "3.IH")
thus ?case using A'' by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (4 i ac t t' A D)
then obtain A'' where A'': "A' = (i,⟨ac: t ≐ t'⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)"
by moura
hence "trms⇩l⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D"
by (metis "4.IH")
thus ?case using A'' by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (5 i t s A D)
hence "A' ∈ set (tr⇩p⇩c A (List.insert (i,t,s) D))" by simp
hence "trms⇩l⇩s⇩t A' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪
pair ` snd ` set (List.insert (i,t,s) D)"
by (metis "5.IH")
thus ?case by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (6 i t s A D)
from 6 obtain Di A'' B C where A'':
"Di ∈ set (subseqs (dbproj i D))" "A'' ∈ set (tr⇩p⇩c A [d←D. d ∉ set Di])" "A' = (B@C)@A''"
"B = map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di"
"C = map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←dbproj i D. d ∉ set Di]"
by moura
hence "trms⇩l⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪
pair ` snd ` set [d←D. d ∉ set Di]"
by (metis "6.IH")
moreover have "set [d←D. d ∉ set Di] ⊆ set D" using set_filter by auto
ultimately have
"trms⇩l⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D"
by blast
hence "trms⇩l⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (unlabel ((i,delete⟨t,s⟩)#A)) ∪
pair ` setops⇩s⇩s⇩t (unlabel ((i,delete⟨t,s⟩)#A)) ∪
pair ` snd ` set D"
using setops⇩s⇩s⇩t_cons_subset trms⇩s⇩s⇩t_cons
by (auto simp add: setops⇩s⇩s⇩t_def)
moreover have "set Di ⊆ set D" "set [d←dbproj i D . d ∉ set Di] ⊆ set D"
using subseqs_set_subset[OF A''(1)] by auto
hence "trms⇩s⇩t (unlabel B) ⊆ insert (pair (t, s)) (pair ` snd ` set D)"
"trms⇩s⇩t (unlabel C) ⊆ insert (pair (t, s)) (pair ` snd ` set D)"
using A''(4,5) unfolding unlabel_def by auto
hence "trms⇩s⇩t (unlabel (B@C)) ⊆ insert (pair (t,s)) (pair ` snd ` set D)"
using unlabel_append[of B C] by auto
moreover have "pair (t,s) ∈ pair ` setops⇩s⇩s⇩t (delete⟨t,s⟩#unlabel A)" by (simp add: setops⇩s⇩s⇩t_def)
ultimately show ?case
using A''(3) trms⇩s⇩t_append[of "unlabel (B@C)" "unlabel A'"] unlabel_append[of "B@C" A'']
by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (7 i ac t s A D)
from 7 obtain d A'' where A'':
"d ∈ set (dbproj i D)" "A'' ∈ set (tr⇩p⇩c A D)"
"A' = (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#A''"
by moura
hence "trms⇩l⇩s⇩t A'' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪
pair ` snd ` set D"
by (metis "7.IH")
moreover have "trms⇩s⇩t (unlabel A') = {pair (t,s), pair (snd d)} ∪ trms⇩s⇩t (unlabel A'')"
using A''(1,3) by auto
ultimately show ?case using A''(1) by (auto simp add: setops⇩s⇩s⇩t_def)
next
case (8 i X F F' A D)
define constr where "constr = map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
define B where "B ≡ ⋃(trms⇩p⇩a⇩i⇩r⇩s ` set (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D))))"
from 8 obtain A'' where A'':
"A'' ∈ set (tr⇩p⇩c A D)" "A' = constr@A''"
unfolding constr_def by moura
have "trms⇩s⇩t (unlabel A'') ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair`snd`set D"
by (metis A''(1) "8.IH")
moreover have "trms⇩s⇩t (unlabel constr) ⊆ B ∪ trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` snd ` set D"
unfolding unlabel_def constr_def B_def by auto
ultimately have "trms⇩s⇩t (unlabel A') ⊆ B ∪ trms⇩p⇩a⇩i⇩r⇩s F ∪ trms⇩s⇩s⇩t (unlabel A) ∪
pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D"
using A'' unlabel_append[of constr A''] by auto
moreover have "set (dbproj i D) ⊆ set D" by auto
hence "B ⊆ pair ` set F' ∪ pair ` snd ` set D"
using tr⇩p⇩a⇩i⇩r⇩s_trms_subset'[of F' "map snd (dbproj i D)"]
unfolding B_def by force
moreover have
"pair ` setops⇩s⇩s⇩t (unlabel ((i, ∀X⟨∨≠: F ∨∉: F'⟩)#A)) =
pair ` set F' ∪ pair ` setops⇩s⇩s⇩t (unlabel A)"
by auto
ultimately show ?case by (auto simp add: setops⇩s⇩s⇩t_def)
qed
lemma tr_par_wf_trms:
assumes "A' ∈ set (tr⇩p⇩c A [])" "wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t (unlabel A))"
shows "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩t A')"
using tr_par_trms_subset[OF assms(1)] setops⇩s⇩s⇩t_wf⇩t⇩r⇩m⇩s(2)[OF assms(2)]
by auto
lemma tr_par_wf':
assumes "fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
and "fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X"
and "wf'⇩s⇩s⇩t X (unlabel A)" "fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
and "A' ∈ set (tr⇩p⇩c A D)"
shows "wf⇩l⇩s⇩t X A'"
proof -
define P where
"P = (λ(D::('fun,'var,'lbl) labeleddbstatelist) (A::('fun,'var,'lbl) labeled_stateful_strand).
(fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}) ∧
fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {})"
have "P D A" using assms(1,4) by (simp add: P_def)
with assms(5,3,2) show ?thesis
proof (induction A arbitrary: X A' D)
case Nil thus ?case by simp
next
case (Cons a A)
obtain i s where i: "a = (i,s)" by (metis surj_pair)
note prems = Cons.prems
note IH = Cons.IH
show ?case
proof (cases s)
case (Receive t)
note si = Receive i
then obtain A'' where A'': "A' = (i,receive⟨t⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)" "fv t ⊆ X"
using prems unlabel_Cons(1)[of i s A] by moura
have *: "wf'⇩s⇩s⇩t X (unlabel A)"
"fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X"
"P D A"
using prems si apply (force, force)
using prems(4) si unfolding P_def by fastforce
show ?thesis using IH[OF A''(2) *] A''(1,3) by simp
next
case (Send t)
note si = Send i
then obtain A'' where A'': "A' = (i,send⟨t⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)"
using prems by moura
have *: "wf'⇩s⇩s⇩t (X ∪ fv t) (unlabel A)"
"fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X ∪ fv t"
"P D A"
using prems si apply (force, force)
using prems(4) si unfolding P_def by fastforce
show ?thesis using IH[OF A''(2) *] A''(1) by simp
next
case (Equality ac t t')
note si = Equality i
then obtain A'' where A'':
"A' = (i,⟨ac: t ≐ t'⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)"
"ac = Assign ⟹ fv t' ⊆ X"
using prems unlabel_Cons(1)[of i s] by moura
have *: "ac = Assign ⟹ wf'⇩s⇩s⇩t (X ∪ fv t) (unlabel A)"
"ac = Check ⟹ wf'⇩s⇩s⇩t X (unlabel A)"
"ac = Assign ⟹ fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X ∪ fv t"
"ac = Check ⟹ fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X"
"P D A"
using prems si apply (force, force, force, force)
using prems(4) si unfolding P_def by fastforce
show ?thesis
using IH[OF A''(2) *(1,3,5)] IH[OF A''(2) *(2,4,5)] A''(1,3)
by (cases ac) simp_all
next
case (Insert t t')
note si = Insert i
hence A': "A' ∈ set (tr⇩p⇩c A (List.insert (i,t,t') D))" "fv t ⊆ X" "fv t' ⊆ X"
using prems by auto
have *: "wf'⇩s⇩s⇩t X (unlabel A)" "fv⇩p⇩a⇩i⇩r⇩s (unlabel (List.insert (i,t,t') D)) ⊆ X"
using prems si by (auto simp add: unlabel_def)
have **: "P (List.insert (i,t,t') D) A"
using prems(4) si
unfolding P_def unlabel_def
by fastforce
show ?thesis using IH[OF A'(1) * **] A'(2,3) by simp
next
case (Delete t t')
note si = Delete i
define constr where "constr = (λDi.
(map (λd. (i,⟨check: (pair (t,t')) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i,∀[]⟨∨≠: [(pair (t,t'), pair (snd d))]⟩⇩s⇩t)) [d←dbproj i D. d ∉ set Di]))"
from prems si obtain Di A'' where A'':
"A' = constr Di@A''" "A'' ∈ set (tr⇩p⇩c A [d←D. d ∉ set Di])"
"Di ∈ set (subseqs (dbproj i D))"
unfolding constr_def by auto
have *: "wf'⇩s⇩s⇩t X (unlabel A)"
"fv⇩p⇩a⇩i⇩r⇩s (unlabel (filter (λd. d ∉ set Di) D)) ⊆ X"
using prems si apply simp
using prems si by (fastforce simp add: unlabel_def)
have "fv⇩p⇩a⇩i⇩r⇩s (unlabel (filter (λd. d ∉ set Di) D)) ⊆ fv⇩p⇩a⇩i⇩r⇩s (unlabel D)"
by (auto simp add: unlabel_def)
hence **: "P [d←D. d ∉ set Di] A"
using prems si unfolding P_def
by fastforce
have ***: "fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X" using prems si by auto
show ?thesis
using IH[OF A''(2) * **] A''(1) wf_pair_eqs_ineqs_map'[OF _ A''(3) ***]
unfolding constr_def by simp
next
case (InSet ac t t')
note si = InSet i
then obtain d A'' where A'':
"A' = (i,⟨ac: (pair (t,t')) ≐ (pair (snd d))⟩⇩s⇩t)#A''"
"A'' ∈ set (tr⇩p⇩c A D)"
"d ∈ set D"
using prems by moura
have *:
"ac = Assign ⟹ wf'⇩s⇩s⇩t (X ∪ fv t ∪ fv t') (unlabel A)"
"ac = Check ⟹ wf'⇩s⇩s⇩t X (unlabel A)"
"ac = Assign ⟹ fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X ∪ fv t ∪ fv t'"
"ac = Check ⟹ fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X"
"P D A"
using prems si apply (force, force, force, force)
using prems(4) si unfolding P_def by fastforce
have **: "fv (pair (snd d)) ⊆ X"
using A''(3) prems(3) fv_pair_fv⇩p⇩a⇩i⇩r⇩s_subset
by fast
have ***: "fv (pair (t,t')) = fv t ∪ fv t'" unfolding pair_def by auto
show ?thesis
using IH[OF A''(2) *(1,3,5)] IH[OF A''(2) *(2,4,5)] A''(1) ** ***
by (cases ac) (simp_all add: Un_assoc)
next
case (NegChecks Y F F')
note si = NegChecks i
then obtain A'' where A'':
"A' = (map (λG. (i,∀Y⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D))))@A''"
"A'' ∈ set (tr⇩p⇩c A D)"
using prems by moura
have *: "wf'⇩s⇩s⇩t X (unlabel A)" "fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ⊆ X" using prems si by auto
have "bvars⇩s⇩s⇩t (unlabel A) ⊆ bvars⇩s⇩s⇩t (unlabel ((i,∀Y⟨∨≠: F ∨∉: F'⟩)#A))"
"fv⇩s⇩s⇩t (unlabel A) ⊆ fv⇩s⇩s⇩t (unlabel ((i,∀Y⟨∨≠: F ∨∉: F'⟩)#A))"
by auto
hence **: "P D A" using prems si unfolding P_def by blast
show ?thesis using IH[OF A''(2) * **] A''(1) wf_pair_negchecks_map' by simp
qed
qed
qed
lemma tr_par_wf:
assumes "A' ∈ set (tr⇩p⇩c A [])"
and "wf⇩s⇩s⇩t (unlabel A)"
and "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t A)"
shows "wf⇩l⇩s⇩t {} A'"
and "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩t A')"
and "fv⇩l⇩s⇩t A' ∩ bvars⇩l⇩s⇩t A' = {}"
using tr_par_wf'[OF _ _ _ _ assms(1)]
tr_par_wf_trms[OF assms(1,3)]
tr_par_vars_disj[OF assms(1)]
assms(2)
by fastforce+
lemma tr_par_tfr⇩s⇩s⇩t⇩p:
assumes "A' ∈ set (tr⇩p⇩c A D)" "list_all tfr⇩s⇩s⇩t⇩p (unlabel A)"
and "fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}" (is "?P0 A D")
and "fv⇩p⇩a⇩i⇩r⇩s (unlabel D) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}" (is "?P1 A D")
and "∀t ∈ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D.
∀t' ∈ pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair ` snd ` set D.
(∃δ. Unifier δ t t') ⟶ Γ t = Γ t'" (is "?P3 A D")
shows "list_all tfr⇩s⇩t⇩p (unlabel A')"
proof -
have sublmm: "list_all tfr⇩s⇩s⇩t⇩p (unlabel A)" "?P0 A D" "?P1 A D" "?P3 A D"
when p: "list_all tfr⇩s⇩s⇩t⇩p (unlabel (a#A))" "?P0 (a#A) D" "?P1 (a#A) D" "?P3 (a#A) D"
for a A D
proof -
show "list_all tfr⇩s⇩s⇩t⇩p (unlabel A)" using p(1) by (simp add: unlabel_def tfr⇩s⇩s⇩t_def)
show "?P0 A D" using p(2) fv⇩s⇩s⇩t_cons_subset unfolding unlabel_def by fastforce
show "?P1 A D" using p(3) bvars⇩s⇩s⇩t_cons_subset unfolding unlabel_def by fastforce
have "setops⇩s⇩s⇩t (unlabel A) ⊆ setops⇩s⇩s⇩t (unlabel (a#A))"
using setops⇩s⇩s⇩t_cons_subset unfolding unlabel_def by auto
thus "?P3 A D" using p(4) by blast
qed
show ?thesis using assms
proof (induction A D arbitrary: A' rule: tr⇩p⇩c.induct)
case 1 thus ?case by simp
next
case (2 i t A D)
note prems = "2.prems"
note IH = "2.IH"
from prems(1) obtain A'' where A'': "A' = (i,send⟨t⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)" by moura
have "list_all tfr⇩s⇩t⇩p (unlabel A'')"
using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)]
by meson
thus ?case using A''(1) by simp
next
case (3 i t A D)
note prems = "3.prems"
note IH = "3.IH"
from prems(1) obtain A'' where A'': "A' = (i,receive⟨t⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)" by moura
have "list_all tfr⇩s⇩t⇩p (unlabel A'')"
using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)]
by meson
thus ?case using A''(1) by simp
next
case (4 i ac t t' A D)
note prems = "4.prems"
note IH = "4.IH"
from prems(1) obtain A'' where A'': "A' = (i,⟨ac: t ≐ t'⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c A D)" by moura
have "list_all tfr⇩s⇩t⇩p (unlabel A'')"
using IH[OF A''(2)] prems(5) sublmm[OF prems(2,3,4,5)]
by meson
thus ?case using A''(1) prems(2) by simp
next
case (5 i t s A D)
note prems = "5.prems"
note IH = "5.IH"
from prems(1) have A': "A' ∈ set (tr⇩p⇩c A (List.insert (i,t,s) D))" by simp
have 1: "list_all tfr⇩s⇩s⇩t⇩p (unlabel A)" using sublmm[OF prems(2,3,4,5)] by simp
have "pair ` setops⇩s⇩s⇩t (unlabel ((i,insert⟨t,s⟩)#A)) ∪ pair`snd`set D =
pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair`snd`set (List.insert (i,t,s) D)"
by (auto simp add: setops⇩s⇩s⇩t_def)
hence 3: "?P3 A (List.insert (i,t,s) D)" using prems(5) by metis
moreover have "?P1 A (List.insert (i,t,s) D)"
using prems(3,4) bvars⇩s⇩s⇩t_cons_subset[of "unlabel A" "insert⟨t,s⟩"]
unfolding unlabel_def
by fastforce
ultimately have "list_all tfr⇩s⇩t⇩p (unlabel A')"
using IH[OF A' sublmm(1,2)[OF prems(2,3,4,5)] _ 3] by metis
thus ?case using A'(1) by auto
next
case (6 i t s A D)
note prems = "6.prems"
note IH = "6.IH"
define constr where constr: "constr ≡ (λDi.
(map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) (filter (λd. d ∉ set Di) (dbproj i D))))"
from prems(1) obtain Di A'' where A'':
"A' = constr Di@A''" "A'' ∈ set (tr⇩p⇩c A (filter (λd. d ∉ set Di) D))"
"Di ∈ set (subseqs (dbproj i D))"
unfolding constr by fastforce
define Q1 where "Q1 ≡ (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀x ∈ (fv⇩p⇩a⇩i⇩r⇩s F) - set X. ∃a. Γ (Var x) = TAtom a)"
define Q2 where "Q2 ≡ (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀f T. Fun f T ∈ subterms⇩s⇩e⇩t (trms⇩p⇩a⇩i⇩r⇩s F) ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))"
have "pair ` setops⇩s⇩s⇩t (unlabel A) ∪ pair`snd`set [d←D. d ∉ set Di]
⊆ pair ` setops⇩s⇩s⇩t (unlabel ((i,delete⟨t,s⟩)#A)) ∪ pair`snd`set D"
using subseqs_set_subset[OF A''(3)] by (force simp add: setops⇩s⇩s⇩t_def)
moreover have "∀a∈M. ∀b∈M. P a b"
when "M ⊆ N" "∀a∈N. ∀b∈N. P a b"
for M N::"('fun, 'var) terms" and P
using that by blast
ultimately have *: "?P3 A (filter (λd. d ∉ set Di) D)"
using prems(5) by presburger
have **: "?P1 A (filter (λd. d ∉ set Di) D)"
using prems(4) bvars⇩s⇩s⇩t_cons_subset[of "unlabel A" "delete⟨t,s⟩"]
unfolding unlabel_def by fastforce
have 1: "list_all tfr⇩s⇩t⇩p (unlabel A'')"
using IH[OF A''(3,2) sublmm(1,2)[OF prems(2,3,4,5)] ** *]
by metis
have 2: "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set (unlabel A'') ∨
(∃d ∈ set Di. u = pair (t,s) ∧ u' = pair (snd d))"
when "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set (unlabel A')" for ac u u'
using that A''(1) unfolding constr unlabel_def by force
have 3:
"∀X⟨∨≠: u⟩⇩s⇩t ∈ set (unlabel A'') ∨
(∃d ∈ set (filter (λd. d ∉ set Di) D). u = [(pair (t,s), pair (snd d))] ∧ Q2 u X)"
when "∀X⟨∨≠: u⟩⇩s⇩t ∈ set (unlabel A')" for X u
using that A''(1) unfolding Q2_def constr unlabel_def by force
have 4: "∀d∈set D. (∃δ. Unifier δ (pair (t,s)) (pair (snd d)))
⟶ Γ (pair (t,s)) = Γ (pair (snd d))"
using prems(5) by (simp add: setops⇩s⇩s⇩t_def)
{ fix ac u u'
assume a: "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set (unlabel A')" "∃δ. Unifier δ u u'"
hence "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set (unlabel A'') ∨ (∃d ∈ set Di. u = pair (t,s) ∧ u' = pair (snd d))"
using 2 by metis
moreover {
assume "⟨ac: u ≐ u'⟩⇩s⇩t ∈ set (unlabel A'')"
hence "tfr⇩s⇩t⇩p (⟨ac: u ≐ u'⟩⇩s⇩t)"
using 1 Ball_set_list_all[of "unlabel A''" tfr⇩s⇩t⇩p]
by fast
} moreover {
fix d assume "d ∈ set Di" "u = pair (t,s)" "u' = pair (snd d)"
hence "∃δ. Unifier δ u u' ⟹ Γ u = Γ u'"
using 4 dbproj_subseq_subset A''(3)
by fast
hence "tfr⇩s⇩t⇩p (⟨ac: u ≐ u'⟩⇩s⇩t)"
using Ball_set_list_all[of "unlabel A''" tfr⇩s⇩t⇩p]
by simp
hence "Γ u = Γ u'" using tfr⇩s⇩t⇩p_list_all_alt_def[of "unlabel A''"]
using a(2) unfolding unlabel_def by auto
} ultimately have "Γ u = Γ u'"
using tfr⇩s⇩t⇩p_list_all_alt_def[of "unlabel A''"] a(2)
unfolding unlabel_def by auto
} moreover {
fix u U
assume "∀U⟨∨≠: u⟩⇩s⇩t ∈ set (unlabel A')"
hence "∀U⟨∨≠: u⟩⇩s⇩t ∈ set (unlabel A'') ∨
(∃d ∈ set (filter (λd. d ∉ set Di) D). u = [(pair (t,s), pair (snd d))] ∧ Q2 u U)"
using 3 by metis
hence "Q1 u U ∨ Q2 u U"
using 1 4 subseqs_set_subset[OF A''(3)] tfr⇩s⇩t⇩p_list_all_alt_def[of "unlabel A''"]
unfolding Q1_def Q2_def
by blast
} ultimately show ?case
using tfr⇩s⇩t⇩p_list_all_alt_def[of "unlabel A'"] unfolding Q1_def Q2_def unlabel_def by blast
next
case (7 i ac t s A D)
note prems = "7.prems"
note IH = "7.IH"
from prems(1) obtain d A'' where A'':
"A' = (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#A''"
"A'' ∈ set (tr⇩p⇩c A D)"
"d ∈ set (dbproj i D)"
by moura
have 1: "list_all tfr⇩s⇩t⇩p (unlabel A'')"
using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
by metis
have 2: "Γ (pair (t,s)) = Γ (pair (snd d))"
when "∃δ. Unifier δ (pair (t,s)) (pair (snd d))"
using that prems(2,5) A''(3) unfolding tfr⇩s⇩s⇩t_def by (simp add: setops⇩s⇩s⇩t_def)
show ?case using A''(1) 1 2 by fastforce
next
case (8 i X F F' A D)
note prems = "8.prems"
note IH = "8.IH"
define constr where
"constr = map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
define Q1 where "Q1 ≡ (λ(F::(('fun,'var) term × ('fun,'var) term) list) X.
∀x ∈ (fv⇩p⇩a⇩i⇩r⇩s F) - set X. ∃a. Γ (Var x) = TAtom a)"
define Q2 where "Q2 ≡ (λ(M::('fun,'var) terms) X.
∀f T. Fun f T ∈ subterms⇩s⇩e⇩t M ⟶ T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X))"
have Q2_subset: "Q2 M' X" when "M' ⊆ M" "Q2 M X" for X M M'
using that unfolding Q2_def by auto
have Q2_supset: "Q2 (M ∪ M') X" when "Q2 M X" "Q2 M' X" for X M M'
using that unfolding Q2_def by auto
from prems obtain A'' where A'': "A' = constr@A''" "A'' ∈ set (tr⇩p⇩c A D)"
using constr_def by moura
have 0: "constr = [(i,∀X⟨∨≠: F⟩⇩s⇩t)]" when "F' = []" using that unfolding constr_def by simp
have 1: "list_all tfr⇩s⇩t⇩p (unlabel A'')"
using IH[OF A''(2) sublmm(1,2,3)[OF prems(2,3,4,5)] sublmm(4)[OF prems(2,3,4,5)]]
by metis
have 2: "(F' = [] ∧ Q1 F X) ∨ Q2 (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') X"
using prems(2) unfolding Q1_def Q2_def by simp
have 3: "F' = [] ⟹ Q1 F X ⟹ list_all tfr⇩s⇩t⇩p (unlabel constr)"
using 0 2 tfr⇩s⇩t⇩p_list_all_alt_def[of "unlabel constr"] unfolding Q1_def by auto
{ fix c assume "c ∈ set (unlabel constr)"
hence "∃G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D))). c = ∀X⟨∨≠: (F@G)⟩⇩s⇩t"
unfolding constr_def unlabel_def by force
} moreover {
fix G
assume G: "G ∈ set (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
and c: "∀X⟨∨≠: (F@G)⟩⇩s⇩t ∈ set (unlabel constr)"
and e: "Q2 (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') X"
have d_Q2: "Q2 (pair ` set (map snd D)) X" unfolding Q2_def
proof (intro allI impI)
fix f T assume "Fun f T ∈ subterms⇩s⇩e⇩t (pair ` set (map snd D))"
then obtain d where d: "d ∈ set (map snd D)" "Fun f T ∈ subterms (pair d)" by force
hence "fv (pair d) ∩ set X = {}"
using prems(4) unfolding pair_def by (force simp add: unlabel_def)
thus "T = [] ∨ (∃s ∈ set T. s ∉ Var ` set X)"
by (metis fv_disj_Fun_subterm_param_cases d(2))
qed
have "trms⇩p⇩a⇩i⇩r⇩s (F@G) ⊆ trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F' ∪ pair ` set (map snd D)"
using tr⇩p⇩a⇩i⇩r⇩s_trms_subset[OF G] by force
hence "Q2 (trms⇩p⇩a⇩i⇩r⇩s (F@G)) X" using Q2_subset[OF _ Q2_supset[OF e d_Q2]] by metis
hence "tfr⇩s⇩t⇩p (∀X⟨∨≠: (F@G)⟩⇩s⇩t)" by (metis Q2_def tfr⇩s⇩t⇩p.simps(2))
} ultimately have 4:
"Q2 (trms⇩p⇩a⇩i⇩r⇩s F ∪ pair ` set F') X ⟹ list_all tfr⇩s⇩t⇩p (unlabel constr)"
using Ball_set by blast
have 5: "list_all tfr⇩s⇩t⇩p (unlabel constr)" using 2 3 4 by metis
show ?case using 1 5 A''(1) by (simp add: unlabel_def)
qed
qed
lemma tr_par_tfr:
assumes "A' ∈ set (tr⇩p⇩c A [])" and "tfr⇩s⇩s⇩t (unlabel A)"
and "fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
shows "tfr⇩s⇩t (unlabel A')"
proof -
have *: "trms⇩l⇩s⇩t A' ⊆ trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A)"
using tr_par_trms_subset[OF assms(1)] by simp
hence "SMP (trms⇩l⇩s⇩t A') ⊆ SMP (trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A))"
using SMP_mono by simp
moreover have "tfr⇩s⇩e⇩t (trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A))"
using assms(2) unfolding tfr⇩s⇩s⇩t_def by fast
ultimately have 1: "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩t A')" by (metis tfr_subset(2)[OF _ *])
have **: "list_all tfr⇩s⇩s⇩t⇩p (unlabel A)" using assms(2) unfolding tfr⇩s⇩s⇩t_def by fast
have "pair ` setops⇩s⇩s⇩t (unlabel A) ⊆
SMP (trms⇩s⇩s⇩t (unlabel A) ∪ pair ` setops⇩s⇩s⇩t (unlabel A)) - Var`𝒱"
using setops⇩s⇩s⇩t_are_pairs unfolding pair_def by auto
hence "Γ t = Γ t'"
when "∃δ. Unifier δ t t'" "t ∈ pair ` setops⇩s⇩s⇩t (unlabel A)" "t' ∈ pair ` setops⇩s⇩s⇩t (unlabel A)"
for t t'
using that assms(2) unfolding tfr⇩s⇩s⇩t_def tfr⇩s⇩e⇩t_def by blast
moreover have "fv⇩p⇩a⇩i⇩r⇩s (unlabel []) = {}" "pair ` snd ` set [] = {}" by auto
ultimately have 2: "list_all tfr⇩s⇩t⇩p (unlabel A')"
using tr_par_tfr⇩s⇩s⇩t⇩p[OF assms(1) ** assms(3)] by simp
show ?thesis by (metis 1 2 tfr⇩s⇩t_def)
qed
lemma tr_par_proj:
assumes "B ∈ set (tr⇩p⇩c A D)"
shows "proj n B ∈ set (tr⇩p⇩c (proj n A) (proj n D))"
using assms
proof (induction A D arbitrary: B rule: tr⇩p⇩c.induct)
case (5 i t s S D)
note prems = "5.prems"
note IH = "5.IH"
have IH': "proj n B ∈ set (tr⇩p⇩c (proj n S) (proj n (List.insert (i,t,s) D)))"
using prems IH by auto
show ?case
proof (cases "(i = ln n) ∨ (i = ⋆)")
case True thus ?thesis
using IH' proj_list_insert(1,2)[of n "(t,s)" D] proj_list_Cons(1,2)[of n _ S]
by auto
next
case False
then obtain m where "i = ln m" "n ≠ m" by (cases i) simp_all
thus ?thesis
using IH' proj_list_insert(3)[of n _ "(t,s)" D] proj_list_Cons(3)[of n _ "insert⟨t,s⟩" S]
by auto
qed
next
case (6 i t s S D)
note prems = "6.prems"
note IH = "6.IH"
define constr where "constr = (λDi D.
(map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←dbproj i D. d ∉ set Di]))"
obtain Di B' where B':
"B = constr Di D@B'"
"Di ∈ set (subseqs (dbproj i D))"
"B' ∈ set (tr⇩p⇩c S [d←D. d ∉ set Di])"
using prems constr_def by fastforce
hence "proj n B' ∈ set (tr⇩p⇩c (proj n S) (proj n [d←D. d ∉ set Di]))" using IH by simp
hence IH': "proj n B' ∈ set (tr⇩p⇩c (proj n S) [d←proj n D. d ∉ set Di])" by (metis proj_filter)
show ?case
proof (cases "(i = ln n) ∨ (i = ⋆)")
case True
hence "proj n B = constr Di D@proj n B'" "Di ∈ set (subseqs (dbproj i (proj n D)))"
using B'(1,2) proj_dbproj(1,2)[of n D] unfolding proj_def constr_def by auto
moreover have "constr Di (proj n D) = constr Di D"
using True proj_dbproj(1,2)[of n D] unfolding constr_def by presburger
ultimately have "proj n B ∈ set (tr⇩p⇩c ((i, delete⟨t,s⟩)#proj n S) (proj n D))"
using IH' unfolding constr_def by force
thus ?thesis by (metis proj_list_Cons(1,2) True)
next
case False
then obtain m where m: "i = ln m" "n ≠ m" by (cases i) simp_all
hence *: "(ln n) ≠ i" by simp
have "proj n B = proj n B'" using B'(1) False unfolding constr_def proj_def by auto
moreover have "[d←proj n D. d ∉ set Di] = proj n D"
using proj_subseq[OF _ m(2)[symmetric]] m(1) B'(2) by simp
ultimately show ?thesis using m(1) IH' proj_list_Cons(3)[OF m(2), of _ S] by auto
qed
next
case (7 i ac t s S D)
note prems = "7.prems"
note IH = "7.IH"
define constr where "constr = (
λd::'lbl strand_label × ('fun,'var) term × ('fun,'var) term.
(i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t))"
obtain d B' where B':
"B = constr d#B'"
"d ∈ set (dbproj i D)"
"B' ∈ set (tr⇩p⇩c S D)"
using prems constr_def by fastforce
hence IH': "proj n B' ∈ set (tr⇩p⇩c (proj n S) (proj n D))" using IH by auto
show ?case
proof (cases "(i = ln n) ∨ (i = ⋆)")
case True
hence "proj n B = constr d#proj n B'" "d ∈ set (dbproj i (proj n D))"
using B' proj_list_Cons(1,2)[of n _ B']
unfolding constr_def
by (force, metis proj_dbproj(1,2))
hence "proj n B ∈ set (tr⇩p⇩c ((i, InSet ac t s)#proj n S) (proj n D))"
using IH' unfolding constr_def by auto
thus ?thesis using proj_list_Cons(1,2)[of n _ S] True by metis
next
case False
then obtain m where m: "i = ln m" "n ≠ m" by (cases i) simp_all
hence "proj n B = proj n B'" using B'(1) proj_list_Cons(3) unfolding constr_def by auto
thus ?thesis
using IH' m proj_list_Cons(3)[OF m(2), of "InSet ac t s" S]
unfolding constr_def
by auto
qed
next
case (8 i X F F' S D)
note prems = "8.prems"
note IH = "8.IH"
define constr where
"constr = (λD. map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D))))"
obtain B' where B':
"B = constr D@B'"
"B' ∈ set (tr⇩p⇩c S D)"
using prems constr_def by fastforce
hence IH': "proj n B' ∈ set (tr⇩p⇩c (proj n S) (proj n D))" using IH by auto
show ?case
proof (cases "(i = ln n) ∨ (i = ⋆)")
case True
hence "proj n B = constr (proj n D)@proj n B'"
using B'(1,2) proj_dbproj(1,2)[of n D] unfolding proj_def constr_def by auto
hence "proj n B ∈ set (tr⇩p⇩c ((i, NegChecks X F F')#proj n S) (proj n D))"
using IH' unfolding constr_def by auto
thus ?thesis using proj_list_Cons(1,2)[of n _ S] True by metis
next
case False
then obtain m where m: "i = ln m" "n ≠ m" by (cases i) simp_all
hence "proj n B = proj n B'" using B'(1) unfolding constr_def proj_def by auto
thus ?thesis
using IH' m proj_list_Cons(3)[OF m(2), of "NegChecks X F F'" S]
unfolding constr_def
by auto
qed
qed (force simp add: proj_def)+
lemma tr_par_preserves_typing_cond:
assumes "par_comp⇩l⇩s⇩s⇩t A Sec" "typing_cond⇩s⇩s⇩t (unlabel A)" "A' ∈ set (tr⇩p⇩c A [])"
shows "typing_cond (unlabel A')"
proof -
have "wf'⇩s⇩s⇩t {} (unlabel A)"
"fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
"wf⇩t⇩r⇩m⇩s (trms⇩s⇩s⇩t (unlabel A))"
using assms(2) unfolding typing_cond⇩s⇩s⇩t_def by simp_all
hence 1: "wf⇩s⇩t {} (unlabel A')"
"fv⇩s⇩t (unlabel A') ∩ bvars⇩s⇩t (unlabel A') = {}"
"wf⇩t⇩r⇩m⇩s (trms⇩s⇩t (unlabel A'))"
"Ana_invar_subst (ik⇩s⇩t (unlabel A') ∪ assignment_rhs⇩s⇩t (unlabel A'))"
using tr_par_wf[OF assms(3)] Ana_invar_subst' by metis+
have 2: "tfr⇩s⇩t (unlabel A')" by (metis tr_par_tfr assms(2,3) typing_cond⇩s⇩s⇩t_def)
show ?thesis by (metis 1 2 typing_cond_def)
qed
lemma tr_par_preserves_par_comp:
assumes "par_comp⇩l⇩s⇩s⇩t A Sec" "A' ∈ set (tr⇩p⇩c A [])"
shows "par_comp A' Sec"
proof -
let ?M = "λl. trms⇩s⇩s⇩t (proj_unl l A) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l A)"
let ?N = "λl. trms_proj⇩l⇩s⇩t l A'"
have 0: "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (?M l1) (?M l2) Sec"
using assms(1) unfolding par_comp⇩l⇩s⇩s⇩t_def by simp_all
{ fix l1 l2::'lbl assume *: "l1 ≠ l2"
hence "GSMP_disjoint (?M l1) (?M l2) Sec" using 0(1) by metis
moreover have "pair ` snd ` set (proj n []) = {}" for n::'lbl unfolding proj_def by simp
hence "?N l1 ⊆ ?M l1" "?N l2 ⊆ ?M l2"
using tr_par_trms_subset[OF tr_par_proj[OF assms(2)]] by (metis Un_empty_right)+
ultimately have "GSMP_disjoint (?N l1) (?N l2) Sec"
using GSMP_disjoint_subset by presburger
} hence 1: "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (trms_proj⇩l⇩s⇩t l1 A') (trms_proj⇩l⇩s⇩t l2 A') Sec"
using 0(1) by metis
have 2: "ground Sec" "∀s ∈ Sec. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ Sec"
using assms(1) unfolding par_comp⇩l⇩s⇩s⇩t_def by metis+
show ?thesis using 1 2 unfolding par_comp_def by metis
qed
lemma tr_leaking_prefix_exists:
assumes "A' ∈ set (tr⇩p⇩c A [])" "prefix B A'" "ik⇩s⇩t (proj_unl n B) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ"
shows "∃C D. prefix C B ∧ prefix D A ∧ C ∈ set (tr⇩p⇩c D []) ∧ (ik⇩s⇩t (proj_unl n C) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ)"
proof -
let ?P = "λB C C'. B = C@C' ∧ (∀n t. (n, receive⟨t⟩⇩s⇩t) ∉ set C') ∧
(C = [] ∨ (∃n t. suffix [(n,receive⟨t⟩⇩s⇩t)] C))"
have "∃C C'. ?P B C C'"
proof (induction B)
case (Cons b B)
then obtain C C' n s where *: "?P B C C'" "b = (n,s)" by moura
show ?case
proof (cases "C = []")
case True
note T = True
show ?thesis
proof (cases "∃t. s = receive⟨t⟩⇩s⇩t")
case True
hence "?P (b#B) [b] C'" using * T by auto
thus ?thesis by metis
next
case False
hence "?P (b#B) [] (b#C')" using * T by auto
thus ?thesis by metis
qed
next
case False
hence "?P (b#B) (b#C) C'" using * unfolding suffix_def by auto
thus ?thesis by metis
qed
qed simp
then obtain C C' where C:
"B = C@C'" "∀n t. (n, receive⟨t⟩⇩s⇩t) ∉ set C'"
"C = [] ∨ (∃n t. suffix [(n,receive⟨t⟩⇩s⇩t)] C)"
by moura
hence 1: "prefix C B" by simp
hence 2: "prefix C A'" using assms(2) by simp
have "⋀m t. (m,receive⟨t⟩⇩s⇩t) ∈ set B ⟹ (m,receive⟨t⟩⇩s⇩t) ∈ set C" using C by auto
hence "⋀t. receive⟨t⟩⇩s⇩t ∈ set (proj_unl n B) ⟹ receive⟨t⟩⇩s⇩t ∈ set (proj_unl n C)"
unfolding unlabel_def proj_def by force
hence "ik⇩s⇩t (proj_unl n B) ⊆ ik⇩s⇩t (proj_unl n C)" using ik⇩s⇩t_is_rcv_set by auto
hence 3: "ik⇩s⇩t (proj_unl n C) ⋅⇩s⇩e⇩t ℐ ⊢ t ⋅ ℐ" by (metis ideduct_mono[OF assms(3)] subst_all_mono)
{ fix D E m t assume "suffix [(m, receive⟨t⟩⇩s⇩t)] E" "prefix E A'" "A' ∈ set (tr⇩p⇩c A D)"
hence "∃F. prefix F A ∧ E ∈ set (tr⇩p⇩c F D)"
proof (induction A D arbitrary: A' E rule: tr⇩p⇩c.induct)
case (1 D) thus ?case by simp
next
case (2 i t' S D)
note prems = "2.prems"
note IH = "2.IH"
obtain A'' where *: "A' = (i,send⟨t'⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c S D)"
using prems(3) by auto
have "E ≠ []" using prems(1) by auto
then obtain E' where **: "E = (i,send⟨t'⟩⇩s⇩t)#E'"
using *(1) prems(2) by (cases E) auto
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E'" "prefix E' A''"
using *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto
then obtain F where "prefix F S" "E' ∈ set (tr⇩p⇩c F D)"
using *(2) ** IH by metis
hence "prefix ((i,Send t')#F) ((i,Send t')#S)" "E ∈ set (tr⇩p⇩c ((i,Send t')#F) D)"
using ** by auto
thus ?case by metis
next
case (3 i t' S D)
note prems = "3.prems"
note IH = "3.IH"
obtain A'' where *: "A' = (i,receive⟨t'⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c S D)"
using prems(3) by auto
have "E ≠ []" using prems(1) by auto
then obtain E' where **: "E = (i,receive⟨t'⟩⇩s⇩t)#E'"
using *(1) prems(2) by (cases E) auto
show ?case
proof (cases "(m, receive⟨t⟩⇩s⇩t) = (i, receive⟨t'⟩⇩s⇩t)")
case True
note T = True
show ?thesis
proof (cases "suffix [(m, receive⟨t⟩⇩s⇩t)] E'")
case True
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E'" "prefix E' A''"
using ** *(1) prems(1,2) by auto
then obtain F where "prefix F S" "E' ∈ set (tr⇩p⇩c F D)"
using *(2) ** IH by metis
hence "prefix ((i,receive⟨t'⟩)#F) ((i,receive⟨t'⟩)#S)"
"E ∈ set (tr⇩p⇩c ((i,receive⟨t'⟩)#F) D)"
using ** by auto
thus ?thesis by metis
next
case False
hence "E' = []"
using **(1) T prems(1)
suffix_Cons[of "[(m, receive⟨t⟩⇩s⇩t)]" "(m, receive⟨t⟩⇩s⇩t)" E']
by auto
hence "prefix [(i,receive⟨t'⟩)] ((i,receive⟨t'⟩) # S) ∧ E ∈ set (tr⇩p⇩c [(i,receive⟨t'⟩)] D)"
using * ** prems by auto
thus ?thesis by metis
qed
next
case False
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E'" "prefix E' A''"
using ** *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto
then obtain F where "prefix F S" "E' ∈ set (tr⇩p⇩c F D)" using *(2) ** IH by metis
hence "prefix ((i,receive⟨t'⟩)#F) ((i,receive⟨t'⟩)#S)" "E ∈ set (tr⇩p⇩c ((i,receive⟨t'⟩)#F) D)"
using ** by auto
thus ?thesis by metis
qed
next
case (4 i ac t' t'' S D)
note prems = "4.prems"
note IH = "4.IH"
obtain A'' where *: "A' = (i,⟨ac: t' ≐ t''⟩⇩s⇩t)#A''" "A'' ∈ set (tr⇩p⇩c S D)"
using prems(3) by auto
have "E ≠ []" using prems(1) by auto
then obtain E' where **: "E = (i,⟨ac: t' ≐ t''⟩⇩s⇩t)#E'"
using *(1) prems(2) by (cases E) auto
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E'" "prefix E' A''"
using *(1) prems(1,2) suffix_Cons[of _ _ E'] by auto
then obtain F where "prefix F S" "E' ∈ set (tr⇩p⇩c F D)"
using *(2) ** IH by metis
hence "prefix ((i,Equality ac t' t'')#F) ((i,Equality ac t' t'')#S)"
"E ∈ set (tr⇩p⇩c ((i,Equality ac t' t'')#F) D)"
using ** by auto
thus ?case by metis
next
case (5 i t' s S D)
note prems = "5.prems"
note IH = "5.IH"
have *: "A' ∈ set (tr⇩p⇩c S (List.insert (i,t',s) D))" using prems(3) by auto
have "E ≠ []" using prems(1) by auto
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E" "prefix E A'"
using *(1) prems(1,2) suffix_Cons[of _ _ E] by auto
then obtain F where "prefix F S" "E ∈ set (tr⇩p⇩c F (List.insert (i,t',s) D))"
using * IH by metis
hence "prefix ((i,insert⟨t',s⟩)#F) ((i,insert⟨t',s⟩)#S)"
"E ∈ set (tr⇩p⇩c ((i,insert⟨t',s⟩)#F) D)"
by auto
thus ?case by metis
next
case (6 i t' s S D)
note prems = "6.prems"
note IH = "6.IH"
define constr where "constr = (λDi.
(map (λd. (i,⟨check: (pair (t',s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i,∀[]⟨∨≠: [(pair (t',s), pair (snd d))]⟩⇩s⇩t))
(filter (λd. d ∉ set Di) (dbproj i D))))"
obtain A'' Di where *:
"A' = constr Di@A''" "A'' ∈ set (tr⇩p⇩c S (filter (λd. d ∉ set Di) D))"
"Di ∈ set (subseqs (dbproj i D))"
using prems(3) constr_def by auto
have ***: "(m, receive⟨t⟩⇩s⇩t) ∉ set (constr Di)" using constr_def by auto
have "E ≠ []" using prems(1) by auto
then obtain E' where **: "E = constr Di@E'"
using *(1) prems(1,2) ***
by (metis (mono_tags, lifting) Un_iff list.set_intros(1) prefixI prefix_def
prefix_same_cases set_append suffix_def)
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E'" "prefix E' A''"
using *(1) prems(1,2) suffix_append[of "[(m,receive⟨t⟩⇩s⇩t)]" "constr Di" E'] ***
by (metis (no_types, hide_lams) Nil_suffix append_Nil2 in_set_conv_decomp rev_exhaust
snoc_suffix_snoc suffix_appendD,
auto)
then obtain F where "prefix F S" "E' ∈ set (tr⇩p⇩c F (filter (λd. d ∉ set Di) D))"
using *(2,3) ** IH by metis
hence "prefix ((i,delete⟨t',s⟩)#F) ((i,delete⟨t',s⟩)#S)"
"E ∈ set (tr⇩p⇩c ((i,delete⟨t',s⟩)#F) D)"
using *(3) ** constr_def by auto
thus ?case by metis
next
case (7 i ac t' s S D)
note prems = "7.prems"
note IH = "7.IH"
define constr where "constr = (
λd::(('lbl strand_label × ('fun,'var) term × ('fun,'var) term)).
(i,⟨ac: (pair (t',s)) ≐ (pair (snd d))⟩⇩s⇩t))"
obtain A'' d where *: "A' = constr d#A''" "A'' ∈ set (tr⇩p⇩c S D)" "d ∈ set (dbproj i D)"
using prems(3) constr_def by auto
have "E ≠ []" using prems(1) by auto
then obtain E' where **: "E = constr d#E'" using *(1) prems(2) by (cases E) auto
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E'" "prefix E' A''"
using *(1) prems(1,2) suffix_Cons[of _ _ E'] using constr_def by auto
then obtain F where "prefix F S" "E' ∈ set (tr⇩p⇩c F D)" using *(2) ** IH by metis
hence "prefix ((i,InSet ac t' s)#F) ((i,InSet ac t' s)#S)"
"E ∈ set (tr⇩p⇩c ((i,InSet ac t' s)#F) D)"
using *(3) ** unfolding constr_def by auto
thus ?case by metis
next
case (8 i X G G' S D)
note prems = "8.prems"
note IH = "8.IH"
define constr where
"constr = map (λH. (i,∀X⟨∨≠: (G@H)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s G' (map snd (dbproj i D)))"
obtain A'' where *: "A' = constr@A''" "A'' ∈ set (tr⇩p⇩c S D)"
using prems(3) constr_def by auto
have ***: "(m, receive⟨t⟩⇩s⇩t) ∉ set constr" using constr_def by auto
have "E ≠ []" using prems(1) by auto
then obtain E' where **: "E = constr@E'"
using *(1) prems(1,2) ***
by (metis (mono_tags, lifting) Un_iff list.set_intros(1) prefixI prefix_def
prefix_same_cases set_append suffix_def)
hence "suffix [(m, receive⟨t⟩⇩s⇩t)] E'" "prefix E' A''"
using *(1) prems(1,2) suffix_append[of "[(m,receive⟨t⟩⇩s⇩t)]" constr E'] ***
by (metis (no_types, hide_lams) Nil_suffix append_Nil2 in_set_conv_decomp rev_exhaust
snoc_suffix_snoc suffix_appendD,
auto)
then obtain F where "prefix F S" "E' ∈ set (tr⇩p⇩c F D)" using *(2) ** IH by metis
hence "prefix ((i,NegChecks X G G')#F) ((i,NegChecks X G G')#S)"
"E ∈ set (tr⇩p⇩c ((i,NegChecks X G G')#F) D)"
using ** constr_def by auto
thus ?case by metis
qed
}
moreover have "prefix [] A" "[] ∈ set (tr⇩p⇩c [] [])" by auto
ultimately have 4: "∃D. prefix D A ∧ C ∈ set (tr⇩p⇩c D [])" using C(3) assms(1) 2 by blast
show ?thesis by (metis 1 3 4)
qed
subsection ‹Theorem: Semantic Equivalence of Translation›
context
begin
text ‹
An alternative version of the translation that does not perform database-state projections.
It is used as an intermediate step in the proof of semantic equivalence.
›
private fun tr'⇩p⇩c::
"('fun,'var,'lbl) labeled_stateful_strand ⇒ ('fun,'var,'lbl) labeleddbstatelist
⇒ ('fun,'var,'lbl) labeled_strand list"
where
"tr'⇩p⇩c [] D = [[]]"
| "tr'⇩p⇩c ((i,send⟨t⟩)#A) D = map ((#) (i,send⟨t⟩⇩s⇩t)) (tr'⇩p⇩c A D)"
| "tr'⇩p⇩c ((i,receive⟨t⟩)#A) D = map ((#) (i,receive⟨t⟩⇩s⇩t)) (tr'⇩p⇩c A D)"
| "tr'⇩p⇩c ((i,⟨ac: t ≐ t'⟩)#A) D = map ((#) (i,⟨ac: t ≐ t'⟩⇩s⇩t)) (tr'⇩p⇩c A D)"
| "tr'⇩p⇩c ((i,insert⟨t,s⟩)#A) D = tr'⇩p⇩c A (List.insert (i,(t,s)) D)"
| "tr'⇩p⇩c ((i,delete⟨t,s⟩)#A) D = (
concat (map (λDi. map (λB. (map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di)@
(map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t))
[d←D. d ∉ set Di])@B)
(tr'⇩p⇩c A [d←D. d ∉ set Di]))
(subseqs D)))"
| "tr'⇩p⇩c ((i,⟨ac: t ∈ s⟩)#A) D =
concat (map (λB. map (λd. (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#B) D) (tr'⇩p⇩c A D))"
| "tr'⇩p⇩c ((i,∀X⟨∨≠: F ∨∉: F'⟩)#A) D =
map ((@) (map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd D)))) (tr'⇩p⇩c A D)"
subsubsection ‹Part 1›
private lemma tr'_par_iff_unlabel_tr:
assumes "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D.
∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D.
p = q ⟶ i = j"
shows "(∃C ∈ set (tr'⇩p⇩c A D). B = unlabel C) ⟷ B ∈ set (tr (unlabel A) (unlabel D))"
(is "?A ⟷ ?B")
proof
{ fix C have "C ∈ set (tr'⇩p⇩c A D) ⟹ unlabel C ∈ set (tr (unlabel A) (unlabel D))" using assms
proof (induction A D arbitrary: C rule: tr'⇩p⇩c.induct)
case (5 i t s S D)
hence "unlabel C ∈ set (tr (unlabel S) (unlabel (List.insert (i, t, s) D)))"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
moreover have
"insert (i,t,s) (set D) ⊆ setops⇩l⇩s⇩s⇩t ((i,insert⟨t,s⟩)#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "∀(j,p) ∈ insert (i,t,s) (set D). ∀(k,q) ∈ insert (i,t,s) (set D). p = q ⟶ j = k"
using "5.prems"(2) by blast
hence "unlabel (List.insert (i, t, s) D) = (List.insert (t, s) (unlabel D))"
using map_snd_list_insert_distrib[of "(i,t,s)" D] unfolding unlabel_def by simp
ultimately show ?case by auto
next
case (6 i t s S D)
let ?f1 = "λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t"
let ?g1 = "λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t"
let ?f2 = "λd. (i, ?f1 (snd d))"
let ?g2 = "λd. (i, ?g1 (snd d))"
define constr1 where "constr1 = (λDi. (map ?f1 Di)@(map ?g1 [d←unlabel D. d ∉ set Di]))"
define constr2 where "constr2 = (λDi. (map ?f2 Di)@(map ?g2 [d←D. d ∉ set Di]))"
obtain C' Di where C':
"Di ∈ set (subseqs D)"
"C = constr2 Di@C'"
"C' ∈ set (tr'⇩p⇩c S [d←D. d ∉ set Di])"
using "6.prems"(1) unfolding constr2_def by moura
have 0: "set [d←D. d ∉ set Di] ⊆ set D"
"setops⇩l⇩s⇩s⇩t S ⊆ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S)"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence 1:
"∀(j, p) ∈ setops⇩l⇩s⇩s⇩t S ∪ set [d←D. d ∉ set Di].
∀(k, q) ∈ setops⇩l⇩s⇩s⇩t S ∪ set [d←D. d ∉ set Di].
p = q ⟶ j = k"
using "6.prems"(2) by blast
have "∀(i,p) ∈ set D ∪ set Di. ∀(j,q) ∈ set D ∪ set Di. p = q ⟶ i = j"
using "6.prems"(2) subseqs_set_subset(1)[OF C'(1)] by blast
hence 2: "unlabel [d←D. d ∉ set Di] = [d←unlabel D. d ∉ set (unlabel Di)]"
using unlabel_filter_eq[of D "set Di"] unfolding unlabel_def by simp
have 3:
"⋀f g::('a × 'a ⇒ 'c). ⋀A B::(('b × 'a × 'a) list).
map snd ((map (λd. (i, f (snd d))) A)@(map (λd. (i, g (snd d))) B)) =
map f (map snd A)@map g (map snd B)"
by simp
have "unlabel (constr2 Di) = constr1 (unlabel Di)"
using 2 3[of ?f1 Di ?g1 "[d←D. d ∉ set Di]"]
by (simp add: constr1_def constr2_def unlabel_def)
hence 4: "unlabel C = constr1 (unlabel Di)@unlabel C'"
using C'(2) unlabel_append by metis
have "unlabel Di ∈ set (map unlabel (subseqs D))"
using C'(1) unfolding unlabel_def by simp
hence 5: "unlabel Di ∈ set (subseqs (unlabel D))"
using map_subseqs[of snd D] unfolding unlabel_def by simp
show ?case using "6.IH"[OF C'(1,3) 1] 2 4 5 unfolding constr1_def by auto
next
case (7 i ac t s S D)
obtain C' d where C':
"C = (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#C'"
"C' ∈ set (tr'⇩p⇩c S D)" "d ∈ set D"
using "7.prems"(1) by moura
have "setops⇩l⇩s⇩s⇩t S ∪ set D ⊆ setops⇩l⇩s⇩s⇩t ((i,InSet ac t s)#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "∀(j, p) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D.
∀(k, q) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D.
p = q ⟶ j = k"
using "7.prems"(2) by blast
hence "unlabel C' ∈ set (tr (unlabel S) (unlabel D))" using "7.IH"[OF C'(2)] by auto
thus ?case using C' unfolding unlabel_def by force
next
case (8 i X F F' S D)
obtain C' where C':
"C = map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd D))@C'"
"C' ∈ set (tr'⇩p⇩c S D)"
using "8.prems"(1) by moura
have "setops⇩l⇩s⇩s⇩t S ∪ set D ⊆ setops⇩l⇩s⇩s⇩t ((i,NegChecks X F F')#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "∀(j, p) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D.
∀(k, q) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D.
p = q ⟶ j = k"
using "8.prems"(2) by blast
hence "unlabel C' ∈ set (tr (unlabel S) (unlabel D))" using "8.IH"[OF C'(2)] by auto
thus ?case using C' unfolding unlabel_def by auto
qed (auto simp add: setops⇩l⇩s⇩s⇩t_def)
} thus "?A ⟹ ?B" by blast
show "?B ⟹ ?A" using assms
proof (induction A arbitrary: B D)
case (Cons a A)
obtain ia sa where a: "a = (ia,sa)" by moura
have "setops⇩l⇩s⇩s⇩t A ⊆ setops⇩l⇩s⇩s⇩t (a#A)" using a by (cases sa) (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence 1: "∀(j, p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D.
∀(k, q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D.
p = q ⟶ j = k"
using Cons.prems(2) by blast
show ?case
proof (cases sa)
case (Send t)
then obtain B' where B':
"B = send⟨t⟩⇩s⇩t#B'"
"B' ∈ set (tr (unlabel A) (unlabel D))"
using Cons.prems(1) a by auto
thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Send by auto
next
case (Receive t)
then obtain B' where B':
"B = receive⟨t⟩⇩s⇩t#B'"
"B' ∈ set (tr (unlabel A) (unlabel D))"
using Cons.prems(1) a by auto
thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Receive by auto
next
case (Equality ac t t')
then obtain B' where B':
"B = ⟨ac: t ≐ t'⟩⇩s⇩t#B'"
"B' ∈ set (tr (unlabel A) (unlabel D))"
using Cons.prems(1) a by auto
thus ?thesis using Cons.IH[OF B'(2) 1] a B'(1) Equality by auto
next
case (Insert t s)
hence B: "B ∈ set (tr (unlabel A) (List.insert (t,s) (unlabel D)))"
using Cons.prems(1) a by auto
let ?P = "λi. List.insert (t,s) (unlabel D) = unlabel (List.insert (i,t,s) D)"
{ obtain j where j: "?P j" "j = ia ∨ (j,t,s) ∈ set D"
using labeled_list_insert_eq_ex_cases[of "(t,s)" D ia] by moura
hence "j = ia" using Cons.prems(2) a Insert by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "?P ia" using j(1) by metis
} hence j: "?P ia" by metis
have 2: "∀(k1, p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set (List.insert (ia,t,s) D).
∀(k2, q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set (List.insert (ia,t,s) D).
p = q ⟶ k1 = k2"
using Cons.prems(2) a Insert by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
show ?thesis using Cons.IH[OF _ 2] j(1) B Insert a by auto
next
case (Delete t s)
define c where "c ≡ (λ(i::'lbl strand_label) Di.
map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di@
map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←D. d ∉ set Di])"
define d where "d ≡ (λDi.
map (λd. ⟨check: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t) Di@
map (λd. ∀[]⟨∨≠: [(pair (t,s), pair d)]⟩⇩s⇩t) [d←unlabel D. d ∉ set Di])"
obtain B' Di where B':
"B = d Di@B'" "Di ∈ set (subseqs (unlabel D))"
"B' ∈ set (tr (unlabel A) [d←unlabel D. d ∉ set Di])"
using Cons.prems(1) a Delete unfolding d_def by auto
obtain Di' where Di': "Di' ∈ set (subseqs D)" "unlabel Di' = Di"
using unlabel_subseqsD[OF B'(2)] by moura
have 2: "∀(j, p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set [d←D. d ∉ set Di'].
∀(k, q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set [d←D. d ∉ set Di'].
p = q ⟶ j = k"
using 1 subseqs_subset[OF Di'(1)]
filter_is_subset[of "λd. d ∉ set Di'"]
by blast
have "set Di' ⊆ set D" by (rule subseqs_subset[OF Di'(1)])
hence "∀(j, p)∈set D ∪ set Di'. ∀(k, q)∈set D ∪ set Di'. p = q ⟶ j = k"
using Cons.prems(2) by blast
hence 3: "[d←unlabel D. d ∉ set Di] = unlabel [d←D. d ∉ set Di']"
using Di'(2) unlabel_filter_eq[of D "set Di'"] unfolding unlabel_def by auto
obtain C where C: "C ∈ set (tr'⇩p⇩c A [d←D. d ∉ set Di'])" "B' = unlabel C"
using 3 Cons.IH[OF _ 2] B'(3) by auto
hence 4: "c ia Di'@C ∈ set (tr'⇩p⇩c (a#A) D)" using Di'(1) a Delete unfolding c_def by auto
have "unlabel (c ia Di') = d Di" using Di' 3 unfolding c_def d_def unlabel_def by auto
hence 5: "B = unlabel (c ia Di'@C)" using B'(1) C(2) unlabel_append[of "c ia Di'" C] by simp
show ?thesis using 4 5 by blast
next
case (InSet ac t s)
then obtain B' d where B':
"B = ⟨ac: (pair (t,s)) ≐ (pair d)⟩⇩s⇩t#B'"
"B' ∈ set (tr (unlabel A) (unlabel D))"
"d ∈ set (unlabel D)"
using Cons.prems(1) a by auto
thus ?thesis using Cons.IH[OF _ 1] a InSet unfolding unlabel_def by auto
next
case (NegChecks X F F')
then obtain B' where B':
"B = map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' (unlabel D))@B'"
"B' ∈ set (tr (unlabel A) (unlabel D))"
using Cons.prems(1) a by auto
thus ?thesis using Cons.IH[OF _ 1] a NegChecks unfolding unlabel_def by auto
qed
qed simp
qed
subsubsection ‹Part 2›
private lemma tr_par_iff_tr'_par:
assumes "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j"
(is "?R3 A D")
and "∀(l,t,s) ∈ set D. (fv t ∪ fv s) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}" (is "?R4 A D")
and "fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}" (is "?R5 A D")
shows "(∃B ∈ set (tr⇩p⇩c A D). ⟦M; unlabel B⟧⇩d ℐ) ⟷ (∃C ∈ set (tr'⇩p⇩c A D). ⟦M; unlabel C⟧⇩d ℐ)"
(is "?P ⟷ ?Q")
proof
{ fix B assume "B ∈ set (tr⇩p⇩c A D)" "⟦M; unlabel B⟧⇩d ℐ"
hence ?Q using assms
proof (induction A D arbitrary: B M rule: tr⇩p⇩c.induct)
case (1 D) thus ?case by simp
next
case (2 i t S D)
note prems = "2.prems"
note IH = "2.IH"
obtain B' where B': "B = (i,send⟨t⟩⇩s⇩t)#B'" "B' ∈ set (tr⇩p⇩c S D)"
using prems(1) by moura
have 1: "⟦M; unlabel B'⟧⇩d ℐ" using prems(2) B'(1) by simp
have 4: "?R3 S D" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
have 7: "M ⊢ t ⋅ ℐ" using prems(2) B'(1) by simp
obtain C where C: "C ∈ set (tr'⇩p⇩c S D)" "⟦M; unlabel C⟧⇩d ℐ"
using IH[OF B'(2) 1 4 5 6] by moura
hence "((i,send⟨t⟩⇩s⇩t)#C) ∈ set (tr'⇩p⇩c ((i,Send t)#S) D)" "⟦M; unlabel ((i,send⟨t⟩⇩s⇩t)#C)⟧⇩d ℐ"
using 7 by auto
thus ?case by metis
next
case (3 i t S D)
note prems = "3.prems"
note IH = "3.IH"
obtain B' where B': "B = (i,receive⟨t⟩⇩s⇩t)#B'" "B' ∈ set (tr⇩p⇩c S D)" using prems(1) by moura
have 1: "⟦insert (t ⋅ ℐ) M; unlabel B'⟧⇩d ℐ " using prems(2) B'(1) by simp
have 4: "?R3 S D" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
obtain C where C: "C ∈ set (tr'⇩p⇩c S D)" "⟦insert (t ⋅ ℐ) M; unlabel C⟧⇩d ℐ"
using IH[OF B'(2) 1 4 5 6] by moura
hence "((i,receive⟨t⟩⇩s⇩t)#C) ∈ set (tr'⇩p⇩c ((i,receive⟨t⟩)#S) D)"
"⟦insert (t ⋅ ℐ) M; unlabel ((i,receive⟨t⟩⇩s⇩t)#C)⟧⇩d ℐ"
by auto
thus ?case by auto
next
case (4 i ac t t' S D)
note prems = "4.prems"
note IH = "4.IH"
obtain B' where B': "B = (i,⟨ac: t ≐ t'⟩⇩s⇩t)#B'" "B' ∈ set (tr⇩p⇩c S D)"
using prems(1) by moura
have 1: "⟦M; unlabel B'⟧⇩d ℐ " using prems(2) B'(1) by simp
have 4: "?R3 S D" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
have 7: "t ⋅ ℐ = t' ⋅ ℐ" using prems(2) B'(1) by simp
obtain C where C: "C ∈ set (tr'⇩p⇩c S D)" "⟦M; unlabel C⟧⇩d ℐ"
using IH[OF B'(2) 1 4 5 6] by moura
hence "((i,⟨ac: t ≐ t'⟩⇩s⇩t)#C) ∈ set (tr'⇩p⇩c ((i,Equality ac t t')#S) D)"
"⟦M; unlabel ((i,⟨ac: t ≐ t'⟩⇩s⇩t)#C)⟧⇩d ℐ"
using 7 by auto
thus ?case by metis
next
case (5 i t s S D)
note prems = "5.prems"
note IH = "5.IH"
have B: "B ∈ set (tr⇩p⇩c S (List.insert (i,t,s) D))" using prems(1) by simp
have 1: "⟦M; unlabel B⟧⇩d ℐ " using prems(2) B(1) by simp
have 4: "?R3 S (List.insert (i,t,s) D)" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S (List.insert (i,t,s) D)" using prems(4,5) by force
have 6: "?R5 S D" using prems(5) by force
show ?case using IH[OF B(1) 1 4 5 6] by simp
next
case (6 i t s S D)
note prems = "6.prems"
note IH = "6.IH"
let ?cl1 = "λDi. map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di"
let ?cu1 = "λDi. map (λd. ⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t) Di"
let ?cl2 = "λDi. map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←dbproj i D. d∉set Di]"
let ?cu2 = "λDi. map (λd. ∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←dbproj i D. d∉set Di]"
let ?dl1 = "λDi. map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di"
let ?du1 = "λDi. map (λd. ⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t) Di"
let ?dl2 = "λDi. map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←D. d∉set Di]"
let ?du2 = "λDi. map (λd. ∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←D. d∉set Di]"
define c where c: "c = (λDi. ?cl1 Di@?cl2 Di)"
define d where d: "d = (λDi. ?dl1 Di@?dl2 Di)"
obtain B' Di where B':
"Di ∈ set (subseqs (dbproj i D))" "B = c Di@B'" "B' ∈ set (tr⇩p⇩c S [d←D. d ∉ set Di])"
using prems(1) c by moura
have 0: "ik⇩s⇩t (unlabel (c Di)) = {}" "ik⇩s⇩t (unlabel (d Di)) = {}"
"unlabel (?cl1 Di) = ?cu1 Di" "unlabel (?cl2 Di) = ?cu2 Di"
"unlabel (?dl1 Di) = ?du1 Di" "unlabel (?dl2 Di) = ?du2 Di"
unfolding c d unlabel_def by force+
have 1: "⟦M; unlabel B'⟧⇩d ℐ " using prems(2) B'(2) 0(1) unfolding unlabel_def by auto
{ fix j p k q
assume "(j, p) ∈ setops⇩l⇩s⇩s⇩t S ∪ set [d←D. d ∉ set Di]"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t S ∪ set [d←D. d ∉ set Di]"
hence "(j, p) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
using dbproj_subseq_subset[OF B'(1)] by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence 4: "?R3 S [d←D. d ∉ set Di]" by blast
have 5: "?R4 S (filter (λd. d ∉ set Di) D)" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
obtain C where C: "C ∈ set (tr'⇩p⇩c S [d←D . d ∉ set Di])" "⟦M; unlabel C⟧⇩d ℐ"
using IH[OF B'(1,3) 1 4 5 6] by moura
have 7: "⟦M; unlabel (c Di)⟧⇩d ℐ" "⟦M; unlabel B'⟧⇩d ℐ"
using prems(2) B'(2) 0(1) strand_sem_split(3,4)[of M "unlabel (c Di)" "unlabel B'"]
unfolding c unlabel_def by auto
have "⟦M; unlabel (?cl2 Di)⟧⇩d ℐ" using 7(1) 0(1) unfolding c unlabel_def by auto
hence "⟦M; ?cu2 Di⟧⇩d ℐ" by (metis 0(4))
moreover {
fix j p k q
assume "(j, p) ∈ {(i, t, s)} ∪ set D ∪ set Di"
"(k, q) ∈ {(i, t, s)} ∪ set D ∪ set Di"
hence "(j, p) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
using dbproj_subseq_subset[OF B'(1)] by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence "∀(j, p) ∈ {(i, t, s)} ∪ set D ∪ set Di.
∀(k, q) ∈ {(i, t, s)} ∪ set D ∪ set Di.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k"
by blast
ultimately have "⟦M; ?du2 Di⟧⇩d ℐ" using labeled_sat_ineq_lift by simp
hence "⟦M; unlabel (?dl2 Di)⟧⇩d ℐ" by (metis 0(6))
moreover have "⟦M; unlabel (?cl1 Di)⟧⇩d ℐ" using 7(1) unfolding c unlabel_def by auto
hence "⟦M; unlabel (?dl1 Di)⟧⇩d ℐ" by (metis 0(3,5))
ultimately have "⟦M; unlabel (d Di)⟧⇩d ℐ" using 0(2) unfolding c d unlabel_def by force
hence 8: "⟦M; unlabel (d Di@C)⟧⇩d ℐ" using 0(2) C(2) unfolding unlabel_def by auto
have 9: "d Di@C ∈ set (tr'⇩p⇩c ((i,delete⟨t,s⟩)#S) D)"
using C(1) dbproj_subseq_in_subseqs[OF B'(1)]
unfolding d unlabel_def by auto
show ?case by (metis 8 9)
next
case (7 i ac t s S D)
note prems = "7.prems"
note IH = "7.IH"
obtain B' d where B':
"B = (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#B'"
"B' ∈ set (tr⇩p⇩c S D)" "d ∈ set (dbproj i D)"
using prems(1) by moura
have 1: "⟦M; unlabel B'⟧⇩d ℐ " using prems(2) B'(1) by simp
{ fix j p k q
assume "(j,p) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D"
"(k,q) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D"
hence "(j,p) ∈ setops⇩l⇩s⇩s⇩t ((i, InSet ac t s)#S) ∪ set D"
"(k,q) ∈ setops⇩l⇩s⇩s⇩t ((i, InSet ac t s)#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence 4: "?R3 S D" by blast
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
have 7: "pair (t,s) ⋅ ℐ = pair (snd d) ⋅ ℐ" using prems(2) B'(1) by simp
obtain C where C: "C ∈ set (tr'⇩p⇩c S D)" "⟦M; unlabel C⟧⇩d ℐ"
using IH[OF B'(2) 1 4 5 6] by moura
hence "((i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#C) ∈ set (tr'⇩p⇩c ((i,InSet ac t s)#S) D)"
"⟦M; unlabel ((i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#C)⟧⇩d ℐ"
using 7 B'(3) by auto
thus ?case by metis
next
case (8 i X F F' S D)
note prems = "8.prems"
note IH = "8.IH"
let ?cl = "map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
let ?cu = "map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
let ?dl = "map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd D))"
let ?du = "map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd D))"
define c where c: "c = ?cl"
define d where d: "d = ?dl"
obtain B' where B': "B = c@B'" "B' ∈ set (tr⇩p⇩c S D)" using prems(1) c by moura
have 0: "ik⇩s⇩t (unlabel c) = {}" "ik⇩s⇩t (unlabel d) = {}"
"unlabel ?cl = ?cu" "unlabel ?dl = ?du"
unfolding c d unlabel_def by force+
have "ik⇩s⇩t (unlabel c) = {}" unfolding c unlabel_def by force
hence 1: "⟦M; unlabel B'⟧⇩d ℐ " using prems(2) B'(1) unfolding unlabel_def by auto
have "setops⇩l⇩s⇩s⇩t S ⊆ setops⇩l⇩s⇩s⇩t ((i, NegChecks X F F')#S)" by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence 4: "?R3 S D" using prems(3) by blast
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
obtain C where C: "C ∈ set (tr'⇩p⇩c S D)" "⟦M; unlabel C⟧⇩d ℐ"
using IH[OF B'(2) 1 4 5 6] by moura
have 7: "⟦M; unlabel c⟧⇩d ℐ" "⟦M; unlabel B'⟧⇩d ℐ"
using prems(2) B'(1) 0(1) strand_sem_split(3,4)[of M "unlabel c" "unlabel B'"]
unfolding c unlabel_def by auto
have 8: "d@C ∈ set (tr'⇩p⇩c ((i,NegChecks X F F')#S) D)"
using C(1) unfolding d unlabel_def by auto
have "⟦M; unlabel ?cl⟧⇩d ℐ" using 7(1) unfolding c unlabel_def by auto
hence "⟦M; ?cu⟧⇩d ℐ" by (metis 0(3))
moreover {
fix j p k q
assume "(j, p) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D"
"(k, q) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D"
hence "(j, p) ∈ setops⇩l⇩s⇩s⇩t ((i, NegChecks X F F')#S) ∪ set D"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t ((i, NegChecks X F F')#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence "∀(j, p) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D.
∀(k, q) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k"
by blast
moreover have "fv⇩p⇩a⇩i⇩r⇩s (map snd D) ∩ set X = {}"
using prems(4) by fastforce
ultimately have "⟦M; ?du⟧⇩d ℐ" using labeled_sat_ineq_dbproj_sem_equiv[of i] by simp
hence "⟦M; unlabel ?dl⟧⇩d ℐ" by (metis 0(4))
hence "⟦M; unlabel d⟧⇩d ℐ" using 0(2) unfolding c d unlabel_def by force
hence 9: "⟦M; unlabel (d@C)⟧⇩d ℐ" using 0(2) C(2) unfolding unlabel_def by auto
show ?case by (metis 8 9)
qed
} thus "?P ⟹ ?Q" by metis
{ fix C assume "C ∈ set (tr'⇩p⇩c A D)" "⟦M; unlabel C⟧⇩d ℐ"
hence ?P using assms
proof (induction A D arbitrary: C M rule: tr'⇩p⇩c.induct)
case (1 D) thus ?case by simp
next
case (2 i t S D)
note prems = "2.prems"
note IH = "2.IH"
obtain C' where C': "C = (i,send⟨t⟩⇩s⇩t)#C'" "C' ∈ set (tr'⇩p⇩c S D)"
using prems(1) by moura
have 1: "⟦M; unlabel C'⟧⇩d ℐ " using prems(2) C'(1) by simp
have 4: "?R3 S D" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
have 7: "M ⊢ t ⋅ ℐ" using prems(2) C'(1) by simp
obtain B where B: "B ∈ set (tr⇩p⇩c S D)" "⟦M; unlabel B⟧⇩d ℐ"
using IH[OF C'(2) 1 4 5 6] by moura
hence "((i,send⟨t⟩⇩s⇩t)#B) ∈ set (tr⇩p⇩c ((i,Send t)#S) D)"
"⟦M; unlabel ((i,send⟨t⟩⇩s⇩t)#B)⟧⇩d ℐ"
using 7 by auto
thus ?case by metis
next
case (3 i t S D)
note prems = "3.prems"
note IH = "3.IH"
obtain C' where C': "C = (i,receive⟨t⟩⇩s⇩t)#C'" "C' ∈ set (tr'⇩p⇩c S D)"
using prems(1) by moura
have 1: "⟦insert (t ⋅ ℐ) M; unlabel C'⟧⇩d ℐ " using prems(2) C'(1) by simp
have 4: "?R3 S D" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
obtain B where B: "B ∈ set (tr⇩p⇩c S D)" "⟦insert (t ⋅ ℐ) M; unlabel B⟧⇩d ℐ"
using IH[OF C'(2) 1 4 5 6] by moura
hence "((i,receive⟨t⟩⇩s⇩t)#B) ∈ set (tr⇩p⇩c ((i,receive⟨t⟩)#S) D)"
"⟦insert (t ⋅ ℐ) M; unlabel ((i,receive⟨t⟩⇩s⇩t)#B)⟧⇩d ℐ"
by auto
thus ?case by auto
next
case (4 i ac t t' S D)
note prems = "4.prems"
note IH = "4.IH"
obtain C' where C': "C = (i,⟨ac: t ≐ t'⟩⇩s⇩t)#C'" "C' ∈ set (tr'⇩p⇩c S D)"
using prems(1) by moura
have 1: "⟦M; unlabel C'⟧⇩d ℐ " using prems(2) C'(1) by simp
have 4: "?R3 S D" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
have 7: "t ⋅ ℐ = t' ⋅ ℐ" using prems(2) C'(1) by simp
obtain B where B: "B ∈ set (tr⇩p⇩c S D)" "⟦M; unlabel B⟧⇩d ℐ"
using IH[OF C'(2) 1 4 5 6] by moura
hence "((i,⟨ac: t ≐ t'⟩⇩s⇩t)#B) ∈ set (tr⇩p⇩c ((i,Equality ac t t')#S) D)"
"⟦M; unlabel ((i,⟨ac: t ≐ t'⟩⇩s⇩t)#B)⟧⇩d ℐ"
using 7 by auto
thus ?case by metis
next
case (5 i t s S D)
note prems = "5.prems"
note IH = "5.IH"
have C: "C ∈ set (tr'⇩p⇩c S (List.insert (i,t,s) D))" using prems(1) by simp
have 1: "⟦M; unlabel C⟧⇩d ℐ " using prems(2) C(1) by simp
have 4: "?R3 S (List.insert (i,t,s) D)" using prems(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
have 5: "?R4 S (List.insert (i,t,s) D)" using prems(4,5) by force
have 6: "?R5 S (List.insert (i,t,s) D)" using prems(5) by force
show ?case using IH[OF C(1) 1 4 5 6] by simp
next
case (6 i t s S D)
note prems = "6.prems"
note IH = "6.IH"
let ?dl1 = "λDi. map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di"
let ?du1 = "λDi. map (λd. ⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t) Di"
let ?dl2 = "λDi. map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←dbproj i D. d∉set Di]"
let ?du2 = "λDi. map (λd. ∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←dbproj i D. d∉set Di]"
let ?cl1 = "λDi. map (λd. (i,⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)) Di"
let ?cu1 = "λDi. map (λd. ⟨check: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t) Di"
let ?cl2 = "λDi. map (λd. (i,∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t)) [d←D. d∉set Di]"
let ?cu2 = "λDi. map (λd. ∀[]⟨∨≠: [(pair (t,s), pair (snd d))]⟩⇩s⇩t) [d←D. d∉set Di]"
define c where c: "c = (λDi. ?cl1 Di@?cl2 Di)"
define d where d: "d = (λDi. ?dl1 Di@?dl2 Di)"
obtain C' Di where C':
"Di ∈ set (subseqs D)" "C = c Di@C'" "C' ∈ set (tr'⇩p⇩c S [d←D. d ∉ set Di])"
using prems(1) c by moura
have 0: "ik⇩s⇩t (unlabel (c Di)) = {}" "ik⇩s⇩t (unlabel (d Di)) = {}"
"unlabel (?cl1 Di) = ?cu1 Di" "unlabel (?cl2 Di) = ?cu2 Di"
"unlabel (?dl1 Di) = ?du1 Di" "unlabel (?dl2 Di) = ?du2 Di"
unfolding c d unlabel_def by force+
have 1: "⟦M; unlabel C'⟧⇩d ℐ " using prems(2) C'(2) 0(1) unfolding unlabel_def by auto
{ fix j p k q
assume "(j, p) ∈ setops⇩l⇩s⇩s⇩t S ∪ set [d←D. d ∉ set Di]"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t S ∪ set [d←D. d ∉ set Di]"
hence "(j, p) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence 4: "?R3 S [d←D. d ∉ set Di]" by blast
have 5: "?R4 S (filter (λd. d ∉ set Di) D)" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
obtain B where B: "B ∈ set (tr⇩p⇩c S [d←D. d ∉ set Di])" "⟦M; unlabel B⟧⇩d ℐ"
using IH[OF C'(1,3) 1 4 5 6] by moura
have 7: "⟦M; unlabel (c Di)⟧⇩d ℐ" "⟦M; unlabel C'⟧⇩d ℐ"
using prems(2) C'(2) 0(1) strand_sem_split(3,4)[of M "unlabel (c Di)" "unlabel C'"]
unfolding c unlabel_def by auto
{ fix j p k q
assume "(j, p) ∈ {(i, t, s)} ∪ set D"
"(k, q) ∈ {(i, t, s)} ∪ set D"
hence "(j, p) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t ((i, delete⟨t,s⟩)#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence "∀(j, p) ∈ {(i, t, s)} ∪ set D.
∀(k, q) ∈ {(i, t, s)} ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k"
by blast
moreover have "⟦M; unlabel (?cl1 Di)⟧⇩d ℐ" using 7(1) unfolding c unlabel_append by auto
hence "⟦M; ?cu1 Di⟧⇩d ℐ" by (metis 0(3))
ultimately have *: "Di ∈ set (subseqs (dbproj i D))"
using labeled_sat_eqs_subseqs[OF C'(1)] by simp
hence 8: "d Di@B ∈ set (tr⇩p⇩c ((i,delete⟨t,s⟩)#S) D)"
using B(1) unfolding d unlabel_def by auto
have "⟦M; unlabel (?cl2 Di)⟧⇩d ℐ" using 7(1) 0(1) unfolding c unlabel_def by auto
hence "⟦M; ?cu2 Di⟧⇩d ℐ" by (metis 0(4))
hence "⟦M; ?du2 Di⟧⇩d ℐ" by (metis labeled_sat_ineq_dbproj)
hence "⟦M; unlabel (?dl2 Di)⟧⇩d ℐ" by (metis 0(6))
moreover have "⟦M; unlabel (?cl1 Di)⟧⇩d ℐ" using 7(1) unfolding c unlabel_def by auto
hence "⟦M; unlabel (?dl1 Di)⟧⇩d ℐ" by (metis 0(3,5))
ultimately have "⟦M; unlabel (d Di)⟧⇩d ℐ" using 0(2) unfolding c d unlabel_def by force
hence 9: "⟦M; unlabel (d Di@B)⟧⇩d ℐ" using 0(2) B(2) unfolding unlabel_def by auto
show ?case by (metis 8 9)
next
case (7 i ac t s S D)
note prems = "7.prems"
note IH = "7.IH"
obtain C' d where C':
"C = (i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#C'"
"C' ∈ set (tr'⇩p⇩c S D)" "d ∈ set D"
using prems(1) by moura
have 1: "⟦M; unlabel C'⟧⇩d ℐ " using prems(2) C'(1) by simp
{ fix j p k q
assume "(j,p) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D"
"(k,q) ∈ setops⇩l⇩s⇩s⇩t S ∪ set D"
hence "(j,p) ∈ setops⇩l⇩s⇩s⇩t ((i, InSet ac t s)#S) ∪ set D"
"(k,q) ∈ setops⇩l⇩s⇩s⇩t ((i, InSet ac t s)#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence 4: "?R3 S D" by blast
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
obtain B where B: "B ∈ set (tr⇩p⇩c S D)" "⟦M; unlabel B⟧⇩d ℐ"
using IH[OF C'(2) 1 4 5 6] by moura
have 7: "pair (t,s) ⋅ ℐ = pair (snd d) ⋅ ℐ" using prems(2) C'(1) by simp
have "(i,t,s) ∈ setops⇩l⇩s⇩s⇩t ((i, InSet ac t s)#S) ∪ set D"
"(fst d, snd d) ∈ setops⇩l⇩s⇩s⇩t ((i, InSet ac t s)#S) ∪ set D"
using C'(3) by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "∃δ. Unifier δ (pair (t,s)) (pair (snd d)) ⟹ i = fst d"
using prems(3) by blast
hence "fst d = i" using 7 by auto
hence 8: "d ∈ set (dbproj i D)" using C'(3) by auto
have 9: "((i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#B) ∈ set (tr⇩p⇩c ((i,InSet ac t s)#S) D)"
using B 8 by auto
have 10: "⟦M; unlabel ((i,⟨ac: (pair (t,s)) ≐ (pair (snd d))⟩⇩s⇩t)#B)⟧⇩d ℐ"
using B 7 8 by auto
show ?case by (metis 9 10)
next
case (8 i X F F' S D)
note prems = "8.prems"
note IH = "8.IH"
let ?dl = "map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
let ?du = "map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd (dbproj i D)))"
let ?cl = "map (λG. (i,∀X⟨∨≠: (F@G)⟩⇩s⇩t)) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd D))"
let ?cu = "map (λG. ∀X⟨∨≠: (F@G)⟩⇩s⇩t) (tr⇩p⇩a⇩i⇩r⇩s F' (map snd D))"
define c where c: "c = ?cl"
define d where d: "d = ?dl"
obtain C' where C': "C = c@C'" "C' ∈ set (tr'⇩p⇩c S D)" using prems(1) c by moura
have 0: "ik⇩s⇩t (unlabel c) = {}" "ik⇩s⇩t (unlabel d) = {}"
"unlabel ?cl = ?cu" "unlabel ?dl = ?du"
unfolding c d unlabel_def by force+
have "ik⇩s⇩t (unlabel c) = {}" unfolding c unlabel_def by force
hence 1: "⟦M; unlabel C'⟧⇩d ℐ " using prems(2) C'(1) unfolding unlabel_def by auto
have "setops⇩l⇩s⇩s⇩t S ⊆ setops⇩l⇩s⇩s⇩t ((i, NegChecks X F F')#S)" by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence 4: "?R3 S D" using prems(3) by blast
have 5: "?R4 S D" using prems(4) by force
have 6: "?R5 S D" using prems(5) by force
obtain B where B: "B ∈ set (tr⇩p⇩c S D)" "⟦M; unlabel B⟧⇩d ℐ"
using IH[OF C'(2) 1 4 5 6] by moura
have 7: "⟦M; unlabel c⟧⇩d ℐ" "⟦M; unlabel C'⟧⇩d ℐ"
using prems(2) C'(1) 0(1) strand_sem_split(3,4)[of M "unlabel c" "unlabel C'"]
unfolding c unlabel_def by auto
have 8: "d@B ∈ set (tr⇩p⇩c ((i,NegChecks X F F')#S) D)"
using B(1) unfolding d unlabel_def by auto
have "⟦M; unlabel ?cl⟧⇩d ℐ" using 7(1) unfolding c unlabel_def by auto
hence "⟦M; ?cu⟧⇩d ℐ" by (metis 0(3))
moreover {
fix j p k q
assume "(j, p) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D"
"(k, q) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D"
hence "(j, p) ∈ setops⇩l⇩s⇩s⇩t ((i, NegChecks X F F')#S) ∪ set D"
"(k, q) ∈ setops⇩l⇩s⇩s⇩t ((i, NegChecks X F F')#S) ∪ set D"
by (auto simp add: setops⇩l⇩s⇩s⇩t_def)
hence "(∃δ. Unifier δ (pair p) (pair q)) ⟹ j = k" using prems(3) by blast
} hence "∀(j, p) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D.
∀(k, q) ∈ ((λ(t,s). (i,t,s)) ` set F') ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ j = k"
by blast
moreover have "fv⇩p⇩a⇩i⇩r⇩s (map snd D) ∩ set X = {}"
using prems(4) by fastforce
ultimately have "⟦M; ?du⟧⇩d ℐ" using labeled_sat_ineq_dbproj_sem_equiv[of i] by simp
hence "⟦M; unlabel ?dl⟧⇩d ℐ" by (metis 0(4))
hence "⟦M; unlabel d⟧⇩d ℐ" using 0(2) unfolding c d unlabel_def by force
hence 9: "⟦M; unlabel (d@B)⟧⇩d ℐ" using 0(2) B(2) unfolding unlabel_def by auto
show ?case by (metis 8 9)
qed
} thus "?Q ⟹ ?P" by metis
qed
subsubsection ‹Part 3›
private lemma tr'_par_sem_equiv:
assumes "∀(l,t,s) ∈ set D. (fv t ∪ fv s) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
and "fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}" "ground M"
and "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j" (is "?R A D")
and ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "⟦M; set (unlabel D) ⋅⇩p⇩s⇩e⇩t ℐ; unlabel A⟧⇩s ℐ ⟷ (∃B ∈ set (tr'⇩p⇩c A D). ⟦M; unlabel B⟧⇩d ℐ)"
(is "?P ⟷ ?Q")
proof -
have 1: "∀(t,s) ∈ set (unlabel D). (fv t ∪ fv s) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
using assms(1) unfolding unlabel_def by force
have 2: "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D. p = q ⟶ i = j"
using assms(4) subst_apply_term_empty by blast
show ?thesis by (metis tr_sem_equiv'[OF 1 assms(2,3) ℐ] tr'_par_iff_unlabel_tr[OF 2])
qed
subsubsection ‹Part 4›
lemma tr_par_sem_equiv:
assumes "∀(l,t,s) ∈ set D. (fv t ∪ fv s) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}"
and "fv⇩s⇩s⇩t (unlabel A) ∩ bvars⇩s⇩s⇩t (unlabel A) = {}" "ground M"
and "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j"
and ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "⟦M; set (unlabel D) ⋅⇩p⇩s⇩e⇩t ℐ; unlabel A⟧⇩s ℐ ⟷ (∃B ∈ set (tr⇩p⇩c A D). ⟦M; unlabel B⟧⇩d ℐ)"
(is "?P ⟷ ?Q")
using tr_par_iff_tr'_par[OF assms(4,1,2), of M ℐ] tr'_par_sem_equiv[OF assms] by metis
end
subsection ‹Theorem: The Stateful Compositionality Result, on the Constraint Level›
theorem par_comp_constr_stateful:
assumes 𝒜: "par_comp⇩l⇩s⇩s⇩t 𝒜 Sec" "typing_cond⇩s⇩s⇩t (unlabel 𝒜)"
and ℐ: "ℐ ⊨⇩s unlabel 𝒜" "interpretation⇩s⇩u⇩b⇩s⇩t ℐ"
shows "∃ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ∧ (ℐ⇩τ ⊨⇩s unlabel 𝒜) ∧
((∀n. ℐ⇩τ ⊨⇩s proj_unl n 𝒜) ∨ (∃𝒜'. prefix 𝒜' 𝒜 ∧ (𝒜' leaks Sec under ℐ⇩τ)))"
proof -
let ?P = "λn A D.
∀(i, p) ∈ setops⇩l⇩s⇩s⇩t (proj n A) ∪ set D.
∀(j, q) ∈ setops⇩l⇩s⇩s⇩t (proj n A) ∪ set D.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j"
have 1: "∀(l, t, t')∈set []. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t (unlabel 𝒜) = {}"
"fv⇩s⇩s⇩t (unlabel 𝒜) ∩ bvars⇩s⇩s⇩t (unlabel 𝒜) = {}" "ground {}"
using 𝒜(2) unfolding typing_cond⇩s⇩s⇩t_def by simp_all
have 2: "⋀n. ∀(l, t, t')∈set []. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t (proj_unl n 𝒜) = {}"
"⋀n. fv⇩s⇩s⇩t (proj_unl n 𝒜) ∩ bvars⇩s⇩s⇩t (proj_unl n 𝒜) = {}"
using 1(1,2) sst_vars_proj_subset[of _ 𝒜] by fast+
have 3: "⋀n. par_comp⇩l⇩s⇩s⇩t (proj n 𝒜) Sec"
using par_comp⇩l⇩s⇩s⇩t_proj[OF 𝒜(1)] by metis
have 4:
"⟦{}; set (unlabel []) ⋅⇩p⇩s⇩e⇩t ℐ'; unlabel 𝒜⟧⇩s ℐ' ⟷
(∃B∈set (tr⇩p⇩c 𝒜 []). ⟦{}; unlabel B⟧⇩d ℐ')"
when ℐ': "interpretation⇩s⇩u⇩b⇩s⇩t ℐ'" for ℐ'
using tr_par_sem_equiv[OF 1 _ ℐ'] 𝒜(1)
unfolding par_comp⇩l⇩s⇩s⇩t_def constr_sem_d_def by auto
obtain 𝒜' where 𝒜': "𝒜' ∈ set (tr⇩p⇩c 𝒜 [])" "ℐ ⊨ ⟨unlabel 𝒜'⟩"
using 4[OF ℐ(2)] ℐ(1) unfolding constr_sem_d_def by moura
obtain ℐ⇩τ where ℐ⇩τ:
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)" "ℐ⇩τ ⊨ ⟨unlabel 𝒜'⟩"
"(∀n. (ℐ⇩τ ⊨ ⟨proj_unl n 𝒜'⟩)) ∨ (∃𝒜''. prefix 𝒜'' 𝒜' ∧ (strand_leaks⇩l⇩s⇩t 𝒜'' Sec ℐ⇩τ))"
using par_comp_constr[OF tr_par_preserves_par_comp[OF 𝒜(1) 𝒜'(1)]
tr_par_preserves_typing_cond[OF 𝒜 𝒜'(1)]
𝒜'(2) ℐ(2)]
by moura
have ℐ⇩τ': "ℐ⇩τ ⊨⇩s unlabel 𝒜" using 4[OF ℐ⇩τ(1)] 𝒜'(1) ℐ⇩τ(4) unfolding constr_sem_d_def by auto
show ?thesis
proof (cases "∀n. (ℐ⇩τ ⊨ ⟨proj_unl n 𝒜'⟩)")
case True
{ fix n assume "ℐ⇩τ ⊨ ⟨proj_unl n 𝒜'⟩"
hence "⟦{}; {}; unlabel (proj n 𝒜)⟧⇩s ℐ⇩τ"
using tr_par_proj[OF 𝒜'(1), of n]
tr_par_sem_equiv[OF 2(1,2) 1(3) _ ℐ⇩τ(1), of n] 3(1)
unfolding par_comp⇩l⇩s⇩s⇩t_def proj_def constr_sem_d_def by force
} thus ?thesis using True ℐ⇩τ(1,2,3) ℐ⇩τ' by metis
next
case False
then obtain 𝒜''::"('fun,'var,'lbl) labeled_strand" where 𝒜'':
"prefix 𝒜'' 𝒜'" "strand_leaks⇩l⇩s⇩t 𝒜'' Sec ℐ⇩τ"
using ℐ⇩τ by blast
moreover {
fix t l assume *: "⟦{}; unlabel (proj l 𝒜'')@[send⟨t⟩⇩s⇩t]⟧⇩d ℐ⇩τ"
have "ℐ⇩τ ⊨ ⟨unlabel (proj l 𝒜'')⟩" "ik⇩s⇩t (unlabel (proj l 𝒜'')) ⋅⇩s⇩e⇩t ℐ⇩τ ⊢ t ⋅ ℐ⇩τ"
using strand_sem_split(3,4)[OF *] unfolding constr_sem_d_def by auto
} ultimately have "∃t ∈ Sec - declassified⇩l⇩s⇩t 𝒜'' ℐ⇩τ. ∃l.
(ℐ⇩τ ⊨ ⟨unlabel (proj l 𝒜'')⟩) ∧ ik⇩s⇩t (unlabel (proj l 𝒜'')) ⋅⇩s⇩e⇩t ℐ⇩τ ⊢ t ⋅ ℐ⇩τ"
unfolding strand_leaks⇩l⇩s⇩t_def constr_sem_d_def by metis
then obtain s m where sm:
"s ∈ Sec - declassified⇩l⇩s⇩t 𝒜'' ℐ⇩τ"
"ℐ⇩τ ⊨ ⟨unlabel (proj m 𝒜'')⟩"
"ik⇩s⇩t (unlabel (proj m 𝒜'')) ⋅⇩s⇩e⇩t ℐ⇩τ ⊢ s ⋅ ℐ⇩τ"
by moura
obtain B::"('fun,'var,'lbl) labeled_strand"
and C::"('fun,'var,'lbl) labeled_stateful_strand"
where BC:
"prefix B 𝒜'" "prefix C 𝒜" "B ∈ set (tr⇩p⇩c C [])"
"ik⇩s⇩t (unlabel (proj m B)) ⋅⇩s⇩e⇩t ℐ⇩τ ⊢ s ⋅ ℐ⇩τ"
"prefix B 𝒜''"
using tr_leaking_prefix_exists[OF 𝒜'(1) 𝒜''(1) sm(3)] prefix_order.order_trans[OF _ 𝒜''(1)]
by auto
have "⟦{}; unlabel (proj m B)⟧⇩d ℐ⇩τ"
using sm(2) BC(5) unfolding prefix_def unlabel_def proj_def constr_sem_d_def by auto
hence BC': "ℐ⇩τ ⊨ ⟨proj_unl m B@[send⟨s⟩⇩s⇩t]⟩"
using BC(4) unfolding constr_sem_d_def by auto
have BC'': "s ∈ Sec - declassified⇩l⇩s⇩t B ℐ⇩τ"
using BC(5) sm(1) unfolding prefix_def declassified⇩l⇩s⇩t_def by auto
have 5: "par_comp⇩l⇩s⇩s⇩t (proj n C) Sec" for n
using 𝒜(1) BC(2) par_comp⇩l⇩s⇩s⇩t_split(1)[THEN par_comp⇩l⇩s⇩s⇩t_proj]
unfolding prefix_def by auto
have "fv⇩s⇩s⇩t (unlabel 𝒜) ∩ bvars⇩s⇩s⇩t (unlabel 𝒜) = {}"
"fv⇩s⇩s⇩t (unlabel C) ⊆ fv⇩s⇩s⇩t (unlabel 𝒜)"
"bvars⇩s⇩s⇩t (unlabel C) ⊆ bvars⇩s⇩s⇩t (unlabel 𝒜)"
using 𝒜(2) BC(2) sst_vars_append_subset(1,2)[of "unlabel C"]
unfolding typing_cond⇩s⇩s⇩t_def prefix_def unlabel_def by auto
hence "fv⇩s⇩s⇩t (proj_unl n C) ∩ bvars⇩s⇩s⇩t (proj_unl n C) = {}" for n
using sst_vars_proj_subset[of _ C] sst_vars_proj_subset[of _ 𝒜]
by blast
hence 6:
"∀(l, t, t')∈set []. (fv t ∪ fv t') ∩ bvars⇩s⇩s⇩t (proj_unl n C) = {}"
"fv⇩s⇩s⇩t (proj_unl n C) ∩ bvars⇩s⇩s⇩t (proj_unl n C) = {}"
"ground {}"
for n
using 2 by auto
have 7: "?P n C []" for n using 5 unfolding par_comp⇩l⇩s⇩s⇩t_def by simp
have "s ⋅ ℐ⇩τ = s" using ℐ⇩τ(1) BC'' 𝒜(1) unfolding par_comp⇩l⇩s⇩s⇩t_def by auto
hence "∃n. (ℐ⇩τ ⊨⇩s proj_unl n C) ∧ ik⇩s⇩s⇩t (proj_unl n C) ⋅⇩s⇩e⇩t ℐ⇩τ ⊢ s ⋅ ℐ⇩τ"
using tr_par_proj[OF BC(3), of m] BC'(1)
tr_par_sem_equiv[OF 6 7 ℐ⇩τ(1), of m]
tr_par_deduct_iff[OF tr_par_proj(1)[OF BC(3)], of ℐ⇩τ m s]
unfolding proj_def constr_sem_d_def by auto
hence "∃n. ℐ⇩τ ⊨⇩s (proj_unl n C@[Send s])" using strand_sem_append_stateful by simp
moreover have "s ∈ Sec - declassified⇩l⇩s⇩s⇩t C ℐ⇩τ" by (metis tr_par_declassified_eq BC(3) BC'')
ultimately show ?thesis using ℐ⇩τ(1,2,3) ℐ⇩τ' BC(2) unfolding strand_leaks⇩l⇩s⇩s⇩t_def by metis
qed
qed
subsection ‹Theorem: The Stateful Compositionality Result, on the Protocol Level›
abbreviation wf⇩l⇩s⇩s⇩t where
"wf⇩l⇩s⇩s⇩t V 𝒜 ≡ wf'⇩s⇩s⇩t V (unlabel 𝒜)"
text ‹
We state our result on the level of protocol traces (i.e., the constraints reachable in a
symbolic execution of the actual protocol). Hence, we do not need to convert protocol strands
to intruder constraints in the following well-formedness definitions.
›
definition wf⇩l⇩s⇩s⇩t⇩s::"('fun,'var,'lbl) labeled_stateful_strand set ⇒ bool" where
"wf⇩l⇩s⇩s⇩t⇩s 𝒮 ≡ (∀𝒜 ∈ 𝒮. wf⇩l⇩s⇩s⇩t {} 𝒜) ∧ (∀𝒜 ∈ 𝒮. ∀𝒜' ∈ 𝒮. fv⇩l⇩s⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩s⇩t 𝒜' = {})"
definition wf⇩l⇩s⇩s⇩t⇩s'::
"('fun,'var,'lbl) labeled_stateful_strand set ⇒ ('fun,'var,'lbl) labeled_stateful_strand ⇒ bool"
where
"wf⇩l⇩s⇩s⇩t⇩s' 𝒮 𝒜 ≡ (∀𝒜' ∈ 𝒮. wf'⇩s⇩s⇩t (wfrestrictedvars⇩l⇩s⇩s⇩t 𝒜) (unlabel 𝒜')) ∧
(∀𝒜' ∈ 𝒮. ∀𝒜'' ∈ 𝒮. fv⇩l⇩s⇩s⇩t 𝒜' ∩ bvars⇩l⇩s⇩s⇩t 𝒜'' = {}) ∧
(∀𝒜' ∈ 𝒮. fv⇩l⇩s⇩s⇩t 𝒜' ∩ bvars⇩l⇩s⇩s⇩t 𝒜 = {}) ∧
(∀𝒜' ∈ 𝒮. fv⇩l⇩s⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩s⇩t 𝒜' = {})"
definition typing_cond_prot_stateful where
"typing_cond_prot_stateful 𝒫 ≡
wf⇩l⇩s⇩s⇩t⇩s 𝒫 ∧
tfr⇩s⇩e⇩t (⋃(trms⇩l⇩s⇩s⇩t ` 𝒫) ∪ pair ` ⋃(setops⇩s⇩s⇩t ` unlabel ` 𝒫)) ∧
wf⇩t⇩r⇩m⇩s (⋃(trms⇩l⇩s⇩s⇩t ` 𝒫)) ∧
(∀S ∈ 𝒫. list_all tfr⇩s⇩s⇩t⇩p (unlabel S))"
definition par_comp_prot_stateful where
"par_comp_prot_stateful 𝒫 Sec ≡
(∀l1 l2. l1 ≠ l2 ⟶
GSMP_disjoint (⋃𝒜 ∈ 𝒫. trms⇩s⇩s⇩t (proj_unl l1 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l1 𝒜))
(⋃𝒜 ∈ 𝒫. trms⇩s⇩s⇩t (proj_unl l2 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l2 𝒜)) Sec) ∧
ground Sec ∧ (∀s ∈ Sec. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ Sec) ∧
(∀(i,p) ∈ ⋃𝒜 ∈ 𝒫. setops⇩l⇩s⇩s⇩t 𝒜. ∀(j,q) ∈ ⋃𝒜 ∈ 𝒫. setops⇩l⇩s⇩s⇩t 𝒜.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j) ∧
typing_cond_prot_stateful 𝒫"
definition component_secure_prot_stateful where
"component_secure_prot_stateful n P Sec attack ≡
(∀𝒜 ∈ P. suffix [(ln n, Send (Fun attack []))] 𝒜 ⟶
(∀ℐ⇩τ. (interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)) ⟶
¬(ℐ⇩τ ⊨⇩s (proj_unl n 𝒜)) ∧
(∀𝒜'. prefix 𝒜' 𝒜 ⟶
(∀t ∈ Sec-declassified⇩l⇩s⇩s⇩t 𝒜' ℐ⇩τ. ¬(ℐ⇩τ ⊨⇩s (proj_unl n 𝒜'@[Send t]))))))"
definition component_leaks_stateful where
"component_leaks_stateful n 𝒜 Sec ≡
(∃𝒜' ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ∧ prefix 𝒜' 𝒜 ∧
(∃t ∈ Sec - declassified⇩l⇩s⇩s⇩t 𝒜' ℐ⇩τ. (ℐ⇩τ ⊨⇩s (proj_unl n 𝒜'@[Send t]))))"
definition unsat_stateful where
"unsat_stateful 𝒜 ≡ (∀ℐ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ ⟶ ¬(ℐ ⊨⇩s unlabel 𝒜))"
lemma wf⇩l⇩s⇩s⇩t⇩s_eqs_wf⇩l⇩s⇩s⇩t⇩s'[simp]: "wf⇩l⇩s⇩s⇩t⇩s S = wf⇩l⇩s⇩s⇩t⇩s' S []"
unfolding wf⇩l⇩s⇩s⇩t⇩s_def wf⇩l⇩s⇩s⇩t⇩s'_def unlabel_def wfrestrictedvars⇩s⇩s⇩t_def by simp
lemma par_comp_prot_impl_par_comp_stateful:
assumes "par_comp_prot_stateful 𝒫 Sec" "𝒜 ∈ 𝒫"
shows "par_comp⇩l⇩s⇩s⇩t 𝒜 Sec"
proof -
have *:
"∀l1 l2. l1 ≠ l2 ⟶
GSMP_disjoint (⋃𝒜 ∈ 𝒫. trms⇩s⇩s⇩t (proj_unl l1 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l1 𝒜))
(⋃𝒜 ∈ 𝒫. trms⇩s⇩s⇩t (proj_unl l2 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l2 𝒜)) Sec"
using assms(1) unfolding par_comp_prot_stateful_def by argo
{ fix l1 l2::'lbl assume **: "l1 ≠ l2"
hence ***:
"GSMP_disjoint (⋃𝒜 ∈ 𝒫. trms⇩s⇩s⇩t (proj_unl l1 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l1 𝒜))
(⋃𝒜 ∈ 𝒫. trms⇩s⇩s⇩t (proj_unl l2 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l2 𝒜)) Sec"
using * by auto
have "GSMP_disjoint (trms⇩s⇩s⇩t (proj_unl l1 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l1 𝒜))
(trms⇩s⇩s⇩t (proj_unl l2 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l2 𝒜)) Sec"
using GSMP_disjoint_subset[OF ***] assms(2) by auto
} hence "∀l1 l2. l1 ≠ l2 ⟶
GSMP_disjoint (trms⇩s⇩s⇩t (proj_unl l1 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l1 𝒜))
(trms⇩s⇩s⇩t (proj_unl l2 𝒜) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l2 𝒜)) Sec"
by metis
moreover have "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t 𝒜. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t 𝒜.
(∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j"
using assms(1,2) unfolding par_comp_prot_stateful_def by blast
ultimately show ?thesis
using assms
unfolding par_comp_prot_stateful_def par_comp⇩l⇩s⇩s⇩t_def
by fast
qed
lemma typing_cond_prot_impl_typing_cond_stateful:
assumes "typing_cond_prot_stateful 𝒫" "𝒜 ∈ 𝒫"
shows "typing_cond⇩s⇩s⇩t (unlabel 𝒜)"
proof -
have 1: "wf'⇩s⇩s⇩t {} (unlabel 𝒜)" "fv⇩l⇩s⇩s⇩t 𝒜 ∩ bvars⇩l⇩s⇩s⇩t 𝒜 = {}"
using assms unfolding typing_cond_prot_stateful_def wf⇩l⇩s⇩s⇩t⇩s_def by auto
have "tfr⇩s⇩e⇩t (⋃(trms⇩l⇩s⇩s⇩t ` 𝒫) ∪ pair ` ⋃(setops⇩s⇩s⇩t ` unlabel ` 𝒫))"
"wf⇩t⇩r⇩m⇩s (⋃(trms⇩l⇩s⇩s⇩t ` 𝒫))"
"trms⇩l⇩s⇩s⇩t 𝒜 ⊆ ⋃(trms⇩l⇩s⇩s⇩t ` 𝒫)"
"SMP (trms⇩l⇩s⇩s⇩t 𝒜 ∪ pair ` setops⇩s⇩s⇩t (unlabel 𝒜)) - Var`𝒱 ⊆
SMP (⋃(trms⇩l⇩s⇩s⇩t ` 𝒫) ∪ pair ` ⋃(setops⇩s⇩s⇩t ` unlabel ` 𝒫)) - Var`𝒱"
using assms SMP_mono[of "trms⇩l⇩s⇩s⇩t 𝒜 ∪ pair ` setops⇩s⇩s⇩t (unlabel 𝒜)"
"⋃(trms⇩l⇩s⇩s⇩t ` 𝒫) ∪ pair ` ⋃(setops⇩s⇩s⇩t ` unlabel ` 𝒫)"]
unfolding typing_cond_prot_stateful_def
by (metis, metis, auto)
hence 2: "tfr⇩s⇩e⇩t (trms⇩l⇩s⇩s⇩t 𝒜 ∪ pair ` setops⇩s⇩s⇩t (unlabel 𝒜))" and 3: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t 𝒜)"
unfolding tfr⇩s⇩e⇩t_def by (meson subsetD)+
have 4: "list_all tfr⇩s⇩s⇩t⇩p (unlabel 𝒜)" using assms unfolding typing_cond_prot_stateful_def by auto
show ?thesis using 1 2 3 4 unfolding typing_cond⇩s⇩s⇩t_def tfr⇩s⇩s⇩t_def by blast
qed
theorem par_comp_constr_prot_stateful:
assumes P: "P = composed_prot Pi" "par_comp_prot_stateful P Sec" "∀n. component_prot n (Pi n)"
and left_secure: "component_secure_prot_stateful n (Pi n) Sec attack"
shows "∀𝒜 ∈ P. suffix [(ln n, Send (Fun attack []))] 𝒜 ⟶
unsat_stateful 𝒜 ∨ (∃m. n ≠ m ∧ component_leaks_stateful m 𝒜 Sec)"
proof -
{ fix 𝒜 𝒜' assume 𝒜: "𝒜 = 𝒜'@[(ln n, Send (Fun attack []))]" "𝒜 ∈ P"
let ?P = "∃𝒜' ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ∧ prefix 𝒜' 𝒜 ∧
(∃t ∈ Sec-declassified⇩l⇩s⇩s⇩t 𝒜' ℐ⇩τ. ∃m. n ≠ m ∧ (ℐ⇩τ ⊨⇩s (proj_unl m 𝒜'@[Send t])))"
have tcp: "typing_cond_prot_stateful P" using P(2) unfolding par_comp_prot_stateful_def by simp
have par_comp: "par_comp⇩l⇩s⇩s⇩t 𝒜 Sec" "typing_cond⇩s⇩s⇩t (unlabel 𝒜)"
using par_comp_prot_impl_par_comp_stateful[OF P(2) 𝒜(2)]
typing_cond_prot_impl_typing_cond_stateful[OF tcp 𝒜(2)]
by metis+
have "unlabel (proj n 𝒜) = proj_unl n 𝒜" "proj_unl n 𝒜 = proj_unl n (proj n 𝒜)"
"⋀A. A ∈ Pi n ⟹ proj n A = A"
"proj n 𝒜 = (proj n 𝒜')@[(ln n, Send (Fun attack []))]"
using P(1,3) 𝒜 by (auto simp add: proj_def unlabel_def component_prot_def composed_prot_def)
moreover have "proj n 𝒜 ∈ Pi n"
using P(1) 𝒜 unfolding composed_prot_def by blast
moreover {
fix A assume "prefix A 𝒜"
hence *: "prefix (proj n A) (proj n 𝒜)" unfolding proj_def prefix_def by force
hence "proj_unl n A = proj_unl n (proj n A)"
"∀I. declassified⇩l⇩s⇩s⇩t A I = declassified⇩l⇩s⇩s⇩t (proj n A) I"
unfolding proj_def declassified⇩l⇩s⇩s⇩t_def by auto
hence "∃B. prefix B (proj n 𝒜) ∧ proj_unl n A = proj_unl n B ∧
(∀I. declassified⇩l⇩s⇩s⇩t A I = declassified⇩l⇩s⇩s⇩t B I)"
using * by metis
}
ultimately have *:
"∀ℐ⇩τ. interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ ∧ wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ) ⟶
¬(ℐ⇩τ ⊨⇩s (proj_unl n 𝒜)) ∧ (∀𝒜'. prefix 𝒜' 𝒜 ⟶
(∀t ∈ Sec - declassified⇩l⇩s⇩s⇩t 𝒜' ℐ⇩τ. ¬(ℐ⇩τ ⊨⇩s (proj_unl n 𝒜'@[Send t]))))"
using left_secure
unfolding component_secure_prot_stateful_def composed_prot_def suffix_def
by metis
{ fix ℐ assume ℐ: "interpretation⇩s⇩u⇩b⇩s⇩t ℐ" "ℐ ⊨⇩s unlabel 𝒜"
obtain ℐ⇩τ where ℐ⇩τ:
"interpretation⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wt⇩s⇩u⇩b⇩s⇩t ℐ⇩τ" "wf⇩t⇩r⇩m⇩s (subst_range ℐ⇩τ)"
"∃𝒜'. prefix 𝒜' 𝒜 ∧ (𝒜' leaks Sec under ℐ⇩τ)"
using par_comp_constr_stateful[OF par_comp ℐ(2,1)] * by moura
hence "∃𝒜'. prefix 𝒜' 𝒜 ∧ (∃t ∈ Sec - declassified⇩l⇩s⇩s⇩t 𝒜' ℐ⇩τ. ∃m.
n ≠ m ∧ (ℐ⇩τ ⊨⇩s (proj_unl m 𝒜'@[Send t])))"
using ℐ⇩τ(4) * unfolding strand_leaks⇩l⇩s⇩s⇩t_def by metis
hence ?P using ℐ⇩τ(1,2,3) by auto
} hence "unsat_stateful 𝒜 ∨ (∃m. n ≠ m ∧ component_leaks_stateful m 𝒜 Sec)"
by (metis unsat_stateful_def component_leaks_stateful_def)
} thus ?thesis unfolding suffix_def by metis
qed
end
subsection ‹Automated Compositionality Conditions›
definition comp_GSMP_disjoint where
"comp_GSMP_disjoint public arity Ana Γ A' B' A B C ≡
let Bδ = B ⋅⇩l⇩i⇩s⇩t var_rename (max_var_set (fv⇩s⇩e⇩t (set A)))
in has_all_wt_instances_of Γ (set A') (set A) ∧
has_all_wt_instances_of Γ (set B') (set Bδ) ∧
finite_SMP_representation arity Ana Γ A ∧
finite_SMP_representation arity Ana Γ Bδ ∧
(∀t ∈ set A. ∀s ∈ set Bδ. Γ t = Γ s ∧ mgu t s ≠ None ⟶
(intruder_synth' public arity {} t ∧ intruder_synth' public arity {} s) ∨
(∃u ∈ set C. is_wt_instance_of_cond Γ t u) ∧ (∃u ∈ set C. is_wt_instance_of_cond Γ s u))"
definition comp_par_comp⇩l⇩s⇩s⇩t where
"comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ pair_fun A M C ≡
let L = remdups (map (the_LabelN ∘ fst) (filter (Not ∘ is_LabelS) A));
MP0 = λB. remdups (trms_list⇩s⇩s⇩t B@map (pair' pair_fun) (setops_list⇩s⇩s⇩t B));
pr = λl. MP0 (proj_unl l A)
in length L > 1 ∧
list_all (wf⇩t⇩r⇩m' arity) (MP0 (unlabel A)) ∧
list_all (wf⇩t⇩r⇩m' arity) C ∧
has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set C)) (set C) ∧
is_TComp_var_instance_closed Γ C ∧
(∀i ∈ set L. ∀j ∈ set L. i ≠ j ⟶
comp_GSMP_disjoint public arity Ana Γ (pr i) (pr j) (M i) (M j) C) ∧
(∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A. i ≠ j ⟶
(let s = pair' pair_fun p; t = pair' pair_fun q
in mgu s (t ⋅ var_rename (max_var s)) = None))"
locale labeled_stateful_typed_model' =
stateful_typed_model' arity public Ana Γ Pair
+ labeled_typed_model' arity public Ana Γ label_witness1 label_witness2
for arity::"'fun ⇒ nat"
and public::"'fun ⇒ bool"
and Ana::"('fun,(('fun,'atom::finite) term_type × nat)) term
⇒ (('fun,(('fun,'atom) term_type × nat)) term list
× ('fun,(('fun,'atom) term_type × nat)) term list)"
and Γ::"('fun,(('fun,'atom) term_type × nat)) term ⇒ ('fun,'atom) term_type"
and Pair::"'fun"
and label_witness1::"'lbl"
and label_witness2::"'lbl"
begin
sublocale labeled_stateful_typed_model
by unfold_locales
lemma GSMP_disjoint_if_comp_GSMP_disjoint:
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
assumes AB'_wf: "list_all (wf⇩t⇩r⇩m' arity) A'" "list_all (wf⇩t⇩r⇩m' arity) B'"
and C_wf: "list_all (wf⇩t⇩r⇩m' arity) C"
and AB'_disj: "comp_GSMP_disjoint public arity Ana Γ A' B' A B C"
shows "GSMP_disjoint (set A') (set B') ((f (set C)) - {m. {} ⊢⇩c m})"
using GSMP_disjointI[of A' B' A B] AB'_wf AB'_disj C_wf
unfolding comp_GSMP_disjoint_def f_def wf⇩t⇩r⇩m_code list_all_iff Let_def by fast
lemma par_comp⇩l⇩s⇩s⇩t_if_comp_par_comp⇩l⇩s⇩s⇩t:
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
assumes A: "comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ Pair A M C"
shows "par_comp⇩l⇩s⇩s⇩t A ((f (set C)) - {m. {} ⊢⇩c m})"
proof (unfold par_comp⇩l⇩s⇩s⇩t_def; intro conjI)
let ?Sec = "(f (set C)) - {m. {} ⊢⇩c m}"
let ?L = "remdups (map (the_LabelN ∘ fst) (filter (Not ∘ is_LabelS) A))"
let ?N1 = "λB. remdups (trms_list⇩s⇩s⇩t B@map (pair' Pair) (setops_list⇩s⇩s⇩t B))"
let ?N2 = "λB. trms⇩s⇩s⇩t B ∪ pair ` setops⇩s⇩s⇩t B"
let ?pr = "λl. ?N1 (proj_unl l A)"
let ?α = "λp. var_rename (max_var (pair p))"
have 0:
"length ?L > 1"
"list_all (wf⇩t⇩r⇩m' arity) (?N1 (unlabel A))"
"list_all (wf⇩t⇩r⇩m' arity) C"
"has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set C)) (set C)"
"is_TComp_var_instance_closed Γ C"
"∀i ∈ set ?L. ∀j ∈ set ?L. i ≠ j ⟶
comp_GSMP_disjoint public arity Ana Γ (?pr i) (?pr j) (M i) (M j) C"
"∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A. i ≠ j ⟶ mgu (pair p) (pair q ⋅ ?α p) = None"
using A unfolding comp_par_comp⇩l⇩s⇩s⇩t_def pair_code by meson+
have L_in_iff: "l ∈ set ?L ⟷ (∃a ∈ set A. is_LabelN l a)" for l by force
have A_wf_trms: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t A ∪ pair ` setops⇩s⇩s⇩t (unlabel A))"
using 0(2)
unfolding pair_code wf⇩t⇩r⇩m_code list_all_iff trms_list⇩s⇩s⇩t_is_trms⇩s⇩s⇩t setops_list⇩s⇩s⇩t_is_setops⇩s⇩s⇩t
by auto
hence A_proj_wf_trms: "wf⇩t⇩r⇩m⇩s (trms⇩l⇩s⇩s⇩t (proj l A) ∪ pair ` setops⇩s⇩s⇩t (proj_unl l A))" for l
using trms⇩s⇩s⇩t_proj_subset(1)[of l A] setops⇩s⇩s⇩t_proj_subset(1)[of l A] by blast
hence A_proj_wf_trms': "list_all (wf⇩t⇩r⇩m' arity) (?N1 (proj_unl l A))" for l
unfolding pair_code wf⇩t⇩r⇩m_code list_all_iff trms_list⇩s⇩s⇩t_is_trms⇩s⇩s⇩t setops_list⇩s⇩s⇩t_is_setops⇩s⇩s⇩t
by auto
note C_wf_trms = 0(3)[unfolded list_all_iff wf⇩t⇩r⇩m_code[symmetric]]
note 1 = has_all_wt_instances_ofD'[OF wf_trms_subterms[OF C_wf_trms] C_wf_trms 0(4)]
have 2: "GSMP (?N2 (proj_unl l A)) ⊆ GSMP (?N2 (proj_unl l' A))" when "l ∉ set ?L" for l l'
using that L_in_iff GSMP_mono[of "?N2 (proj_unl l A)" "?N2 (proj_unl l' A)"]
trms⇩s⇩s⇩t_unlabel_subset_if_no_label[of l A]
setops⇩s⇩s⇩t_unlabel_subset_if_no_label[of l A]
unfolding list_ex_iff by fast
have 3: "GSMP_disjoint (?N2 (proj_unl l1 A)) (?N2 (proj_unl l2 A)) ?Sec"
when "l1 ∈ set ?L" "l2 ∈ set ?L" "l1 ≠ l2" for l1 l2
proof -
have "GSMP_disjoint (set (?N1 (proj_unl l1 A))) (set (?N1 (proj_unl l2 A))) ?Sec"
using 0(6) that
GSMP_disjoint_if_comp_GSMP_disjoint[
OF A_proj_wf_trms'[of l1] A_proj_wf_trms'[of l2] 0(3),
of "M l1" "M l2"]
unfolding f_def by blast
thus ?thesis
unfolding pair_code trms_list⇩s⇩s⇩t_is_trms⇩s⇩s⇩t setops_list⇩s⇩s⇩t_is_setops⇩s⇩s⇩t
by simp
qed
obtain a1 a2 where a: "a1 ∈ set ?L" "a2 ∈ set ?L" "a1 ≠ a2"
using remdups_ex2[OF 0(1)] by moura
show "ground ?Sec" unfolding f_def by fastforce
{ fix i p j q
assume p: "(i,p) ∈ setops⇩l⇩s⇩s⇩t A" and q: "(j,q) ∈ setops⇩l⇩s⇩s⇩t A"
and pq: "∃δ. Unifier δ (pair p) (pair q)"
have "∃δ. Unifier δ (pair p) (pair q ⋅ ?α p)"
using pq vars_term_disjoint_imp_unifier[OF var_rename_fv_disjoint[of "pair p"], of _ "pair q"]
by (metis (no_types, lifting) subst_subst_compose var_rename_inv_comp)
hence "i = j" using 0(7) mgu_None_is_subst_neq[of "pair p" "pair q ⋅ ?α p"] p q by fast
} thus "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A. (∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j"
by blast
show "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (?N2 (proj_unl l1 A)) (?N2 (proj_unl l2 A)) ?Sec"
using 2 3 3[OF a] unfolding GSMP_disjoint_def by blast
show "∀s ∈ ?Sec. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ ?Sec"
proof (intro ballI)
fix s s'
assume s: "s ∈ ?Sec" and s': "s' ⊑ s"
then obtain t δ where t: "t ∈ set C" "s = t ⋅ δ" "fv s = {}" "¬{} ⊢⇩c s"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
unfolding f_def by blast
obtain m θ where m: "m ∈ set C" "s' = m ⋅ θ" and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using TComp_var_and_subterm_instance_closed_has_subterms_instances[
OF 0(5,4) C_wf_trms in_subterms_Union[OF t(1)] s'[unfolded t(2)] δ]
by blast
thus "{} ⊢⇩c s' ∨ s' ∈ ?Sec"
using ground_subterm[OF t(3) s']
unfolding f_def by blast
qed
qed
lemma par_comp⇩l⇩s⇩s⇩t_if_comp_par_comp⇩l⇩s⇩s⇩t':
defines "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
assumes a: "comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ Pair A M C"
and B: "∀b ∈ set B. ∃a ∈ set A. ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧ wt⇩s⇩u⇩b⇩s⇩t δ ∧ wf⇩t⇩r⇩m⇩s (subst_range δ)"
(is "∀b ∈ set B. ∃a ∈ set A. ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧ ?D δ")
shows "par_comp⇩l⇩s⇩s⇩t B ((f (set C)) - {m. {} ⊢⇩c m})"
proof (unfold par_comp⇩l⇩s⇩s⇩t_def; intro conjI)
define N1 where "N1 ≡ λB::('fun, ('fun,'atom) term_type × nat) stateful_strand.
remdups (trms_list⇩s⇩s⇩t B@map (pair' Pair) (setops_list⇩s⇩s⇩t B))"
define N2 where "N2 ≡ λB::('fun, ('fun,'atom) term_type × nat) stateful_strand.
trms⇩s⇩s⇩t B ∪ pair ` setops⇩s⇩s⇩t B"
define L where "L ≡ λA::('fun, ('fun,'atom) term_type × nat, 'lbl) labeled_stateful_strand.
remdups (map (the_LabelN ∘ fst) (filter (Not ∘ is_LabelS) A))"
define α where "α ≡ λp. var_rename (max_var (pair p::('fun, ('fun,'atom) term_type × nat) term))
::('fun, ('fun,'atom) term_type × nat) subst"
let ?Sec = "(f (set C)) - {m. {} ⊢⇩c m}"
have 0:
"length (L A) > 1"
"list_all (wf⇩t⇩r⇩m' arity) (N1 (unlabel A))"
"list_all (wf⇩t⇩r⇩m' arity) C"
"has_all_wt_instances_of Γ (subterms⇩s⇩e⇩t (set C)) (set C)"
"is_TComp_var_instance_closed Γ C"
"∀i ∈ set (L A). ∀j ∈ set (L A). i ≠ j ⟶
comp_GSMP_disjoint public arity Ana Γ (N1 (proj_unl i A)) (N1 (proj_unl j A)) (M i) (M j) C"
"∀(i,p) ∈ setops⇩l⇩s⇩s⇩t A. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t A. i ≠ j ⟶ mgu (pair p) (pair q ⋅ α p) = None"
using a unfolding comp_par_comp⇩l⇩s⇩s⇩t_def pair_code L_def N1_def α_def by meson+
note 1 = trms⇩s⇩s⇩t_proj_subset(1) setops⇩s⇩s⇩t_proj_subset(1)
have N1_iff_N2: "set (N1 A) = N2 A" for A
unfolding pair_code trms_list⇩s⇩s⇩t_is_trms⇩s⇩s⇩t setops_list⇩s⇩s⇩t_is_setops⇩s⇩s⇩t N1_def N2_def by simp
have N2_proj_subset: "N2 (proj_unl l A) ⊆ N2 (unlabel A)"
for l::'lbl and A::"('fun, ('fun,'atom) term_type × nat, 'lbl) labeled_stateful_strand"
using 1(1)[of l A] image_mono[OF 1(2)[of l A], of pair] unfolding N2_def by blast
have L_in_iff: "l ∈ set (L A) ⟷ (∃a ∈ set A. is_LabelN l a)" for l A
unfolding L_def by force
have L_B_subset_A: "l ∈ set (L A)" when l: "l ∈ set (L B)" for l
using L_in_iff[of l B] L_in_iff[of l A] B l by fastforce
note B_setops = setops⇩l⇩s⇩s⇩t_wt_instance_ex[OF B]
have B_proj: "∀b ∈ set (proj l B). ∃a ∈ set (proj l A). ∃δ. b = a ⋅⇩l⇩s⇩s⇩t⇩p δ ∧ ?D δ" for l
using proj_instance_ex[OF B] by fast
have B': "∀t ∈ N2 (unlabel B). ∃s ∈ N2 (unlabel A). ∃δ. t = s ⋅ δ ∧ ?D δ"
using trms⇩s⇩s⇩t_setops⇩s⇩s⇩t_wt_instance_ex[OF B] unfolding N2_def by blast
have B'_proj: "∀t ∈ N2 (proj_unl l B). ∃s ∈ N2 (proj_unl l A). ∃δ. t = s ⋅ δ ∧ ?D δ" for l
using trms⇩s⇩s⇩t_setops⇩s⇩s⇩t_wt_instance_ex[OF B_proj] unfolding N2_def by presburger
have A_wf_trms: "wf⇩t⇩r⇩m⇩s (N2 (unlabel A))"
using N1_iff_N2[of "unlabel A"] 0(2) unfolding wf⇩t⇩r⇩m_code list_all_iff by auto
hence A_proj_wf_trms: "wf⇩t⇩r⇩m⇩s (N2 (proj_unl l A))" for l
using 1[of l] unfolding N2_def by blast
hence A_proj_wf_trms': "list_all (wf⇩t⇩r⇩m' arity) (N1 (proj_unl l A))" for l
using N1_iff_N2[of "proj_unl l A"] unfolding wf⇩t⇩r⇩m_code list_all_iff by presburger
note C_wf_trms = 0(3)[unfolded list_all_iff wf⇩t⇩r⇩m_code[symmetric]]
have 2: "GSMP (N2 (proj_unl l A)) ⊆ GSMP (N2 (proj_unl l' A))"
when "l ∉ set (L A)" for l l'
and A::"('fun, ('fun,'atom) term_type × nat, 'lbl) labeled_stateful_strand"
using that L_in_iff[of _ A] GSMP_mono[of "N2 (proj_unl l A)" "N2 (proj_unl l' A)"]
trms⇩s⇩s⇩t_unlabel_subset_if_no_label[of l A]
setops⇩s⇩s⇩t_unlabel_subset_if_no_label[of l A]
unfolding list_ex_iff N2_def by fast
have 3: "GSMP (N2 (proj_unl l B)) ⊆ GSMP (N2 (proj_unl l A))" (is "?X ⊆ ?Y") for l
proof
fix t assume "t ∈ ?X"
hence t: "t ∈ SMP (N2 (proj_unl l B))" "fv t = {}" unfolding GSMP_def by simp_all
have "t ∈ SMP (N2 (proj_unl l A))"
using t(1) B'_proj[of l] SMP_wt_instances_subset[of "N2 (proj_unl l B)" "N2 (proj_unl l A)"]
by metis
thus "t ∈ ?Y" using t(2) unfolding GSMP_def by fast
qed
have "GSMP_disjoint (N2 (proj_unl l1 A)) (N2 (proj_unl l2 A)) ?Sec"
when "l1 ∈ set (L A)" "l2 ∈ set (L A)" "l1 ≠ l2" for l1 l2
proof -
have "GSMP_disjoint (set (N1 (proj_unl l1 A))) (set (N1 (proj_unl l2 A))) ?Sec"
using 0(6) that
GSMP_disjoint_if_comp_GSMP_disjoint[
OF A_proj_wf_trms'[of l1] A_proj_wf_trms'[of l2] 0(3),
of "M l1" "M l2"]
unfolding f_def by blast
thus ?thesis using N1_iff_N2 by simp
qed
hence 4: "GSMP_disjoint (N2 (proj_unl l1 B)) (N2 (proj_unl l2 B)) ?Sec"
when "l1 ∈ set (L A)" "l2 ∈ set (L A)" "l1 ≠ l2" for l1 l2
using that 3 unfolding GSMP_disjoint_def by blast
{ fix i p j q
assume p: "(i,p) ∈ setops⇩l⇩s⇩s⇩t B" and q: "(j,q) ∈ setops⇩l⇩s⇩s⇩t B"
and pq: "∃δ. Unifier δ (pair p) (pair q)"
obtain p' δp where p': "(i,p') ∈ setops⇩l⇩s⇩s⇩t A" "p = p' ⋅⇩p δp" "pair p = pair p' ⋅ δp"
using p B_setops unfolding pair_def by auto
obtain q' δq where q': "(j,q') ∈ setops⇩l⇩s⇩s⇩t A" "q = q' ⋅⇩p δq" "pair q = pair q' ⋅ δq"
using q B_setops unfolding pair_def by auto
obtain θ where "Unifier θ (pair p) (pair q)" using pq by blast
hence "∃δ. Unifier δ (pair p') (pair q' ⋅ α p')"
using p'(3) q'(3) var_rename_inv_comp[of "pair q'"] subst_subst_compose
vars_term_disjoint_imp_unifier[
OF var_rename_fv_disjoint[of "pair p'"],
of "δp ∘⇩s θ" "pair q'" "var_rename_inv (max_var_set (fv (pair p'))) ∘⇩s δq ∘⇩s θ"]
unfolding α_def by fastforce
hence "i = j"
using mgu_None_is_subst_neq[of "pair p'" "pair q' ⋅ α p'"] p'(1) q'(1) 0(7)
unfolding α_def by fast
} thus "∀(i,p) ∈ setops⇩l⇩s⇩s⇩t B. ∀(j,q) ∈ setops⇩l⇩s⇩s⇩t B. (∃δ. Unifier δ (pair p) (pair q)) ⟶ i = j"
by blast
obtain a1 a2 where a: "a1 ∈ set (L A)" "a2 ∈ set (L A)" "a1 ≠ a2"
using remdups_ex2[OF 0(1)[unfolded L_def]] unfolding L_def by moura
show "∀l1 l2. l1 ≠ l2 ⟶ GSMP_disjoint (N2 (proj_unl l1 B)) (N2 (proj_unl l2 B)) ?Sec"
using 2[of _ B] 4 4[OF a] L_B_subset_A unfolding GSMP_disjoint_def by blast
show "ground ?Sec" unfolding f_def by fastforce
show "∀s ∈ ?Sec. ∀s' ∈ subterms s. {} ⊢⇩c s' ∨ s' ∈ ?Sec"
proof (intro ballI)
fix s s'
assume s: "s ∈ ?Sec" and s': "s' ⊑ s"
then obtain t δ where t: "t ∈ set C" "s = t ⋅ δ" "fv s = {}" "¬{} ⊢⇩c s"
and δ: "wt⇩s⇩u⇩b⇩s⇩t δ" "wf⇩t⇩r⇩m⇩s (subst_range δ)"
unfolding f_def by blast
obtain m θ where m: "m ∈ set C" "s' = m ⋅ θ" and θ: "wt⇩s⇩u⇩b⇩s⇩t θ" "wf⇩t⇩r⇩m⇩s (subst_range θ)"
using TComp_var_and_subterm_instance_closed_has_subterms_instances[
OF 0(5,4) C_wf_trms in_subterms_Union[OF t(1)] s'[unfolded t(2)] δ]
by blast
thus "{} ⊢⇩c s' ∨ s' ∈ ?Sec"
using ground_subterm[OF t(3) s']
unfolding f_def by blast
qed
qed
end
end
Theory Example_Keyserver
section ‹The Keyserver Example›
text ‹\label{sec:Example-Keyserver}›
theory Example_Keyserver
imports "../Stateful_Compositionality"
begin
declare [[code_timing]]
subsection ‹Setup›
subsubsection ‹Datatypes and functions setup›
datatype ex_lbl = Label1 ("𝟭") | Label2 ("𝟮")
datatype ex_atom =
Agent | Value | Attack | PrivFunSec
| Bot
datatype ex_fun =
ring | valid | revoked | events | beginauth nat | endauth nat | pubkeys | seen
| invkey | tuple | tuple' | attack nat
| sign | crypt | update | pw
| encodingsecret | pubkey nat
| pubconst ex_atom nat
type_synonym ex_type = "(ex_fun, ex_atom) term_type"
type_synonym ex_var = "ex_type × nat"
lemma ex_atom_UNIV:
"(UNIV::ex_atom set) = {Agent, Value, Attack, PrivFunSec, Bot}"
by (auto intro: ex_atom.exhaust)
instance ex_atom::finite
by intro_classes (metis ex_atom_UNIV finite.emptyI finite.insertI)
lemma ex_lbl_UNIV:
"(UNIV::ex_lbl set) = {Label1, Label2}"
by (auto intro: ex_lbl.exhaust)
type_synonym ex_term = "(ex_fun, ex_var) term"
type_synonym ex_terms = "(ex_fun, ex_var) terms"
primrec arity::"ex_fun ⇒ nat" where
"arity ring = 2"
| "arity valid = 3"
| "arity revoked = 3"
| "arity events = 1"
| "arity (beginauth _) = 3"
| "arity (endauth _) = 3"
| "arity pubkeys = 2"
| "arity seen = 2"
| "arity invkey = 2"
| "arity tuple = 2"
| "arity tuple' = 2"
| "arity (attack _) = 0"
| "arity sign = 2"
| "arity crypt = 2"
| "arity update = 4"
| "arity pw = 2"
| "arity (pubkey _) = 0"
| "arity encodingsecret = 0"
| "arity (pubconst _ _) = 0"
fun public::"ex_fun ⇒ bool" where
"public (pubkey _) = False"
| "public encodingsecret = False"
| "public _ = True"
fun Ana⇩c⇩r⇩y⇩p⇩t::"ex_term list ⇒ (ex_term list × ex_term list)" where
"Ana⇩c⇩r⇩y⇩p⇩t [k,m] = ([Fun invkey [Fun encodingsecret [], k]], [m])"
| "Ana⇩c⇩r⇩y⇩p⇩t _ = ([], [])"
fun Ana⇩s⇩i⇩g⇩n::"ex_term list ⇒ (ex_term list × ex_term list)" where
"Ana⇩s⇩i⇩g⇩n [k,m] = ([], [m])"
| "Ana⇩s⇩i⇩g⇩n _ = ([], [])"
fun Ana::"ex_term ⇒ (ex_term list × ex_term list)" where
"Ana (Fun tuple T) = ([], T)"
| "Ana (Fun tuple' T) = ([], T)"
| "Ana (Fun sign T) = Ana⇩s⇩i⇩g⇩n T"
| "Ana (Fun crypt T) = Ana⇩c⇩r⇩y⇩p⇩t T"
| "Ana _ = ([], [])"
subsubsection ‹Keyserver example: Locale interpretation›
lemma assm1:
"Ana t = (K,M) ⟹ fv⇩s⇩e⇩t (set K) ⊆ fv t"
"Ana t = (K,M) ⟹ (⋀g S'. Fun g S' ⊑ t ⟹ length S' = arity g)
⟹ k ∈ set K ⟹ Fun f T' ⊑ k ⟹ length T' = arity f"
"Ana t = (K,M) ⟹ K ≠ [] ∨ M ≠ [] ⟹ Ana (t ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ, M ⋅⇩l⇩i⇩s⇩t δ)"
by (rule Ana.cases[of "t"], auto elim!: Ana⇩c⇩r⇩y⇩p⇩t.elims Ana⇩s⇩i⇩g⇩n.elims)+
lemma assm2: "Ana (Fun f T) = (K, M) ⟹ set M ⊆ set T"
by (rule Ana.cases[of "Fun f T"]) (auto elim!: Ana⇩c⇩r⇩y⇩p⇩t.elims Ana⇩s⇩i⇩g⇩n.elims)
lemma assm6: "0 < arity f ⟹ public f" by (cases f) simp_all
global_interpretation im: intruder_model arity public Ana
defines wf⇩t⇩r⇩m = "im.wf⇩t⇩r⇩m"
by unfold_locales (metis assm1(1), metis assm1(2),rule Ana.simps, metis assm2, metis assm1(3))
type_synonym ex_strand_step = "(ex_fun,ex_var) strand_step"
type_synonym ex_strand = "(ex_fun,ex_var) strand"
subsubsection ‹Typing function›
definition Γ⇩v::"ex_var ⇒ ex_type" where
"Γ⇩v v = (if (∀t ∈ subterms (fst v). case t of
(TComp f T) ⇒ arity f > 0 ∧ arity f = length T
| _ ⇒ True)
then fst v else TAtom Bot)"
fun Γ::"ex_term ⇒ ex_type" where
"Γ (Var v) = Γ⇩v v"
| "Γ (Fun (attack _) _) = TAtom Attack"
| "Γ (Fun (pubkey _) _) = TAtom Value"
| "Γ (Fun encodingsecret _) = TAtom PrivFunSec"
| "Γ (Fun (pubconst τ _) _) = TAtom τ"
| "Γ (Fun f T) = TComp f (map Γ T)"
subsubsection ‹Locale interpretation: typed model›
lemma assm7: "arity c = 0 ⟹ ∃a. ∀X. Γ (Fun c X) = TAtom a" by (cases c) simp_all
lemma assm8: "0 < arity f ⟹ Γ (Fun f X) = TComp f (map Γ X)" by (cases f) simp_all
lemma assm9: "infinite {c. Γ (Fun c []) = TAtom a ∧ public c}"
proof -
let ?T = "(range (pubconst a))::ex_fun set"
have *:
"⋀x y::nat. x ∈ UNIV ⟹ y ∈ UNIV ⟹ (pubconst a x = pubconst a y) = (x = y)"
"⋀x::nat. x ∈ UNIV ⟹ pubconst a x ∈ ?T"
"⋀y::ex_fun. y ∈ ?T ⟹ ∃x ∈ UNIV. y = pubconst a x"
by auto
have "?T ⊆ {c. Γ (Fun c []) = TAtom a ∧ public c}" by auto
moreover have "∃f::nat ⇒ ex_fun. bij_betw f UNIV ?T"
using bij_betwI'[OF *] by blast
hence "infinite ?T" by (metis nat_not_finite bij_betw_finite)
ultimately show ?thesis using infinite_super by blast
qed
lemma assm10: "TComp f T ⊑ Γ t ⟹ arity f > 0"
proof (induction rule: Γ.induct)
case (1 x)
hence *: "TComp f T ⊑ Γ⇩v x" by simp
hence "Γ⇩v x ≠ TAtom Bot" unfolding Γ⇩v_def by force
hence "∀t ∈ subterms (fst x). case t of
(TComp f T) ⇒ arity f > 0 ∧ arity f = length T
| _ ⇒ True"
unfolding Γ⇩v_def by argo
thus ?case using * unfolding Γ⇩v_def by fastforce
qed auto
lemma assm11: "im.wf⇩t⇩r⇩m (Γ (Var x))"
proof -
have "im.wf⇩t⇩r⇩m (Γ⇩v x)" unfolding Γ⇩v_def im.wf⇩t⇩r⇩m_def by auto
thus ?thesis by simp
qed
lemma assm12: "Γ (Var (τ, n)) = Γ (Var (τ, m))"
apply (cases "∀t ∈ subterms τ. case t of
(TComp f T) ⇒ arity f > 0 ∧ arity f = length T
| _ ⇒ True")
by (auto simp add: Γ⇩v_def)
lemma Ana_const: "arity c = 0 ⟹ Ana (Fun c T) = ([], [])"
by (cases c) simp_all
lemma Ana_subst': "Ana (Fun f T) = (K,M) ⟹ Ana (Fun f T ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ,M ⋅⇩l⇩i⇩s⇩t δ)"
by (cases f) (auto elim!: Ana⇩c⇩r⇩y⇩p⇩t.elims Ana⇩s⇩i⇩g⇩n.elims)
global_interpretation tm: typed_model' arity public Ana Γ
by (unfold_locales, unfold wf⇩t⇩r⇩m_def[symmetric])
(metis assm7, metis assm8, metis assm9, metis assm10, metis assm11, metis assm6,
metis assm12, metis Ana_const, metis Ana_subst')
subsubsection ‹Locale interpretation: labeled stateful typed model›
global_interpretation stm: labeled_stateful_typed_model' arity public Ana Γ tuple 𝟭 𝟮
by standard (rule arity.simps, metis Ana_subst', metis assm12, metis Ana_const, simp)
type_synonym ex_stateful_strand_step = "(ex_fun,ex_var) stateful_strand_step"
type_synonym ex_stateful_strand = "(ex_fun,ex_var) stateful_strand"
type_synonym ex_labeled_stateful_strand_step =
"(ex_fun,ex_var,ex_lbl) labeled_stateful_strand_step"
type_synonym ex_labeled_stateful_strand =
"(ex_fun,ex_var,ex_lbl) labeled_stateful_strand"
subsection ‹Theorem: Type-flaw resistance of the keyserver example from the CSF18 paper›
abbreviation "PK n ≡ Var (TAtom Value,n)"
abbreviation "A n ≡ Var (TAtom Agent,n)"
abbreviation "X n ≡ (TAtom Agent,n)"
abbreviation "ringset t ≡ Fun ring [Fun encodingsecret [], t]"
abbreviation "validset t t' ≡ Fun valid [Fun encodingsecret [], t, t']"
abbreviation "revokedset t t' ≡ Fun revoked [Fun encodingsecret [], t, t']"
abbreviation "eventsset ≡ Fun events [Fun encodingsecret []]"
abbreviation S⇩k⇩s::"(ex_fun,ex_var) stateful_strand_step list" where
"S⇩k⇩s ≡ [
insert⟨Fun (attack 0) [], eventsset⟩,
delete⟨PK 0, validset (A 0) (A 0)⟩,
∀(TAtom Agent,0)⟨PK 0 not in revokedset (A 0) (A 0)⟩,
∀(TAtom Agent,0)⟨PK 0 not in validset (A 0) (A 0)⟩,
insert⟨PK 0, validset (A 0) (A 0)⟩,
insert⟨PK 0, ringset (A 0)⟩,
insert⟨PK 0, revokedset (A 0) (A 0)⟩,
select⟨PK 0, validset (A 0) (A 0)⟩,
select⟨PK 0, ringset (A 0)⟩,
receive⟨Fun invkey [Fun encodingsecret [], PK 0]⟩,
receive⟨Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]]⟩,
send⟨Fun invkey [Fun encodingsecret [], PK 0]⟩,
send⟨Fun sign [Fun invkey [Fun encodingsecret [], PK 0], Fun tuple' [A 0, PK 0]]⟩
]"
theorem "stm.tfr⇩s⇩s⇩t S⇩k⇩s"
proof -
let ?M = "concat (map subterms_list (trms_list⇩s⇩s⇩t S⇩k⇩s@map (pair' tuple) (setops_list⇩s⇩s⇩t S⇩k⇩s)))"
have "comp_tfr⇩s⇩s⇩t arity Ana Γ tuple ?M S⇩k⇩s" by eval
thus ?thesis by (rule stm.tfr⇩s⇩s⇩t_if_comp_tfr⇩s⇩s⇩t)
qed
subsection ‹Theorem: Type-flaw resistance of the keyserver examples from the ESORICS18 paper›
abbreviation "signmsg t t' ≡ Fun sign [t, t']"
abbreviation "cryptmsg t t' ≡ Fun crypt [t, t']"
abbreviation "invkeymsg t ≡ Fun invkey [Fun encodingsecret [], t]"
abbreviation "updatemsg a b c d ≡ Fun update [a,b,c,d]"
abbreviation "pwmsg t t' ≡ Fun pw [t, t']"
abbreviation "beginauthset n t t' ≡ Fun (beginauth n) [Fun encodingsecret [], t, t']"
abbreviation "endauthset n t t' ≡ Fun (endauth n) [Fun encodingsecret [], t, t']"
abbreviation "pubkeysset t ≡ Fun pubkeys [Fun encodingsecret [], t]"
abbreviation "seenset t ≡ Fun seen [Fun encodingsecret [], t]"
declare [[coercion "Var::ex_var ⇒ ex_term"]]
declare [[coercion_enabled]]
definition S'⇩k⇩s::"ex_labeled_stateful_strand_step list" where
"S'⇩k⇩s ≡ [
⟨𝟭, send⟨invkeymsg (PK 0)⟩⟩,
⟨⋆, ⟨PK 0 in validset (A 0) (A 1)⟩⟩,
⟨𝟭, receive⟨Fun (attack 0) []⟩⟩,
⟨𝟭, send⟨signmsg (invkeymsg (PK 0)) (Fun tuple' [A 0, PK 0])⟩⟩,
⟨⋆, ⟨PK 0 in validset (A 0) (A 1)⟩⟩,
⟨⋆, ∀X 0, X 1⟨PK 0 not in validset (Var (X 0)) (Var (X 1))⟩⟩,
⟨𝟭, ∀X 0, X 1⟨PK 0 not in revokedset (Var (X 0)) (Var (X 1))⟩⟩,
⟨⋆, ⟨PK 0 not in beginauthset 0 (A 0) (A 1)⟩⟩,
⟨⋆, ⟨PK 0 in beginauthset 0 (A 0) (A 1)⟩⟩,
⟨⋆, ⟨PK 0 in endauthset 0 (A 0) (A 1)⟩⟩,
⟨⋆, receive⟨PK 0⟩⟩,
⟨⋆, receive⟨invkeymsg (PK 0)⟩⟩,
⟨𝟭, insert⟨PK 0, ringset (A 0)⟩⟩,
⟨⋆, insert⟨PK 0, validset (A 0) (A 1)⟩⟩,
⟨⋆, insert⟨PK 0, beginauthset 0 (A 0) (A 1)⟩⟩,
⟨⋆, insert⟨PK 0, endauthset 0 (A 0) (A 1)⟩⟩,
⟨𝟭, select⟨PK 0, ringset (A 0)⟩⟩,
⟨𝟭, delete⟨PK 0, ringset (A 0)⟩⟩,
⟨⋆, ⟨PK 0 not in endauthset 0 (A 0) (A 1)⟩⟩,
⟨⋆, delete⟨PK 0, validset (A 0) (A 1)⟩⟩,
⟨𝟭, insert⟨PK 0, revokedset (A 0) (A 1)⟩⟩,
⟨𝟭, send⟨PK 0⟩⟩,
⟨𝟭, send⟨Fun (attack 0) []⟩⟩,
⟨𝟮, send⟨invkeymsg (PK 0)⟩⟩,
⟨⋆, ⟨PK 0 in validset (A 0) (A 1)⟩⟩,
⟨𝟮, receive⟨Fun (attack 1) []⟩⟩,
⟨𝟮, send⟨cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1)))⟩⟩,
⟨𝟮, select⟨PK 0, pubkeysset (A 0)⟩⟩,
⟨𝟮, ∀X 0⟨PK 0 not in pubkeysset (Var (X 0))⟩⟩,
⟨𝟮, ∀X 0⟨PK 0 not in seenset (Var (X 0))⟩⟩,
⟨⋆, ⟨PK 0 in beginauthset 1 (A 0) (A 1)⟩⟩,
⟨⋆, ⟨PK 0 in endauthset 1 (A 0) (A 1)⟩⟩,
⟨⋆, receive⟨PK 0⟩⟩,
⟨⋆, receive⟨invkeymsg (PK 0)⟩⟩,
⟨𝟮, select⟨PK 0, pubkeysset (A 0)⟩⟩,
⟨⋆, insert⟨PK 0, beginauthset 1 (A 0) (A 1)⟩⟩,
⟨𝟮, receive⟨cryptmsg (PK 0) (updatemsg (A 0) (A 1) (PK 1) (pwmsg (A 0) (A 1)))⟩⟩,
⟨⋆, ⟨PK 0 not in endauthset 1 (A 0) (A 1)⟩⟩,
⟨⋆, insert⟨PK 0, validset (A 0) (A 1)⟩⟩,
⟨⋆, insert⟨PK 0, endauthset 1 (A 0) (A 1)⟩⟩,
⟨𝟮, insert⟨PK 0, seenset (A 0)⟩⟩,
⟨𝟮, receive⟨pwmsg (A 0) (A 1)⟩⟩,
⟨𝟮, insert⟨PK 0, pubkeysset (A 0)⟩⟩,
⟨𝟮, send⟨Fun (attack 1) []⟩⟩
]"
theorem "stm.tfr⇩s⇩s⇩t (unlabel S'⇩k⇩s)"
proof -
let ?S = "unlabel S'⇩k⇩s"
let ?M = "concat (map subterms_list (trms_list⇩s⇩s⇩t ?S@map (pair' tuple) (setops_list⇩s⇩s⇩t ?S)))"
have "comp_tfr⇩s⇩s⇩t arity Ana Γ tuple ?M ?S" by eval
thus ?thesis by (rule stm.tfr⇩s⇩s⇩t_if_comp_tfr⇩s⇩s⇩t)
qed
subsection ‹Theorem: The steps of the keyserver protocols from the ESORICS18 paper satisfy the conditions for parallel composition›
theorem
fixes S f
defines "S ≡ [PK 0, invkeymsg (PK 0), Fun encodingsecret []]@concat (
map (λs. [s, Fun tuple [PK 0, s]])
[validset (A 0) (A 1), beginauthset 0 (A 0) (A 1), endauthset 0 (A 0) (A 1),
beginauthset 1 (A 0) (A 1), endauthset 1 (A 0) (A 1)])@
[A 0]"
and "f ≡ λM. {t ⋅ δ | t δ. t ∈ M ∧ tm.wt⇩s⇩u⇩b⇩s⇩t δ ∧ im.wf⇩t⇩r⇩m⇩s (subst_range δ) ∧ fv (t ⋅ δ) = {}}"
and "Sec ≡ (f (set S)) - {m. im.intruder_synth {} m}"
shows "stm.par_comp⇩l⇩s⇩s⇩t S'⇩k⇩s Sec"
proof -
let ?N = "λP. concat (map subterms_list (trms_list⇩s⇩s⇩t P@map (pair' tuple) (setops_list⇩s⇩s⇩t P)))"
let ?M = "λl. ?N (proj_unl l S'⇩k⇩s)"
have "comp_par_comp⇩l⇩s⇩s⇩t public arity Ana Γ tuple S'⇩k⇩s ?M S"
unfolding S_def by eval
thus ?thesis
using stm.par_comp⇩l⇩s⇩s⇩t_if_comp_par_comp⇩l⇩s⇩s⇩t[of S'⇩k⇩s ?M S]
unfolding Sec_def f_def wf⇩t⇩r⇩m_def[symmetric] by blast
qed
end
Theory Example_TLS
section ‹Proving Type-Flaw Resistance of the TLS Handshake Protocol›
text ‹\label{sec:Example-TLS}›
theory Example_TLS
imports "../Typed_Model"
begin
declare [[code_timing]]
subsection ‹TLS example: Datatypes and functions setup›
datatype ex_atom = PrivKey | SymKey | PubConst | Agent | Nonce | Bot
datatype ex_fun =
clientHello | clientKeyExchange | clientFinished
| serverHello | serverCert | serverHelloDone
| finished | changeCipher | x509 | prfun | master | pmsForm
| sign | hash | crypt | pub | concat | privkey nat
| pubconst ex_atom nat
type_synonym ex_type = "(ex_fun, ex_atom) term_type"
type_synonym ex_var = "ex_type × nat"
instance ex_atom::finite
proof
let ?S = "UNIV::ex_atom set"
have "?S = {PrivKey, SymKey, PubConst, Agent, Nonce, Bot}" by (auto intro: ex_atom.exhaust)
thus "finite ?S" by (metis finite.emptyI finite.insertI)
qed
type_synonym ex_term = "(ex_fun, ex_var) term"
type_synonym ex_terms = "(ex_fun, ex_var) terms"
primrec arity::"ex_fun ⇒ nat" where
"arity changeCipher = 0"
| "arity clientFinished = 4"
| "arity clientHello = 5"
| "arity clientKeyExchange = 1"
| "arity concat = 5"
| "arity crypt = 2"
| "arity finished = 1"
| "arity hash = 1"
| "arity master = 3"
| "arity pmsForm = 1"
| "arity prfun = 1"
| "arity (privkey _) = 0"
| "arity pub = 1"
| "arity (pubconst _ _) = 0"
| "arity serverCert = 1"
| "arity serverHello = 5"
| "arity serverHelloDone = 0"
| "arity sign = 2"
| "arity x509 = 2"
fun public::"ex_fun ⇒ bool" where
"public (privkey _) = False"
| "public _ = True"
fun Ana⇩c⇩r⇩y⇩p⇩t::"ex_term list ⇒ (ex_term list × ex_term list)" where
"Ana⇩c⇩r⇩y⇩p⇩t [Fun pub [k],m] = ([k], [m])"
| "Ana⇩c⇩r⇩y⇩p⇩t _ = ([], [])"
fun Ana⇩s⇩i⇩g⇩n::"ex_term list ⇒ (ex_term list × ex_term list)" where
"Ana⇩s⇩i⇩g⇩n [k,m] = ([], [m])"
| "Ana⇩s⇩i⇩g⇩n _ = ([], [])"
fun Ana::"ex_term ⇒ (ex_term list × ex_term list)" where
"Ana (Fun crypt T) = Ana⇩c⇩r⇩y⇩p⇩t T"
| "Ana (Fun finished T) = ([], T)"
| "Ana (Fun master T) = ([], T)"
| "Ana (Fun pmsForm T) = ([], T)"
| "Ana (Fun serverCert T) = ([], T)"
| "Ana (Fun serverHello T) = ([], T)"
| "Ana (Fun sign T) = Ana⇩s⇩i⇩g⇩n T"
| "Ana (Fun x509 T) = ([], T)"
| "Ana _ = ([], [])"
subsection ‹TLS example: Locale interpretation›
lemma assm1:
"Ana t = (K,M) ⟹ fv⇩s⇩e⇩t (set K) ⊆ fv t"
"Ana t = (K,M) ⟹ (⋀g S'. Fun g S' ⊑ t ⟹ length S' = arity g)
⟹ k ∈ set K ⟹ Fun f T' ⊑ k ⟹ length T' = arity f"
"Ana t = (K,M) ⟹ K ≠ [] ∨ M ≠ [] ⟹ Ana (t ⋅ δ) = (K ⋅⇩l⇩i⇩s⇩t δ, M ⋅⇩l⇩i⇩s⇩t δ)"
by (rule Ana.cases[of "t"], auto elim!: Ana⇩c⇩r⇩y⇩p⇩t.elims Ana⇩s⇩i⇩g⇩n.elims)+
lemma assm2: "Ana (Fun f T) = (K, M) ⟹ set M ⊆ set T"
by (rule Ana.cases[of "Fun f T"]) (auto elim!: Ana⇩c⇩r⇩y⇩p⇩t.elims Ana⇩s⇩i⇩g⇩n.elims)
lemma assm6: "0 < arity f ⟹ public f" by (cases f) simp_all
global_interpretation im: intruder_model arity public Ana
defines wf⇩t⇩r⇩m = "im.wf⇩t⇩r⇩m"
and wf⇩t⇩r⇩m⇩s = "im.wf⇩t⇩r⇩m⇩s"
by unfold_locales (metis assm1(1), metis assm1(2), rule Ana.simps, metis assm2, metis assm1(3))
subsection ‹TLS Example: Typing function›
definition Γ⇩v::"ex_var ⇒ ex_type" where
"Γ⇩v v = (if (∀t ∈ subterms (fst v). case t of
(TComp f T) ⇒ arity f > 0 ∧ arity f = length T
| _ ⇒ True)
then fst v else TAtom Bot)"
fun Γ::"ex_term ⇒ ex_type" where
"Γ (Var v) = Γ⇩v v"
| "Γ (Fun (privkey _) _) = TAtom PrivKey"
| "Γ (Fun changeCipher _) = TAtom PubConst"
| "Γ (Fun serverHelloDone _) = TAtom PubConst"
| "Γ (Fun (pubconst τ _) _) = TAtom τ"
| "Γ (Fun f T) = TComp f (map Γ T)"
subsection ‹TLS Example: Locale interpretation (typed model)›
lemma assm7: "arity c = 0 ⟹ ∃a. ∀X. Γ (Fun c X) = TAtom a" by (cases c) simp_all
lemma assm8: "0 < arity f ⟹ Γ (Fun f X) = TComp f (map Γ X)" by (cases f) simp_all
lemma assm9: "infinite {c. Γ (Fun c []) = TAtom a ∧ public c}"
proof -
let ?T = "(range (pubconst a))::ex_fun set"
have *:
"⋀x y::nat. x ∈ UNIV ⟹ y ∈ UNIV ⟹ (pubconst a x = pubconst a y) = (x = y)"
"⋀x::nat. x ∈ UNIV ⟹ pubconst a x ∈ ?T"
"⋀y::ex_fun. y ∈ ?T ⟹ ∃x ∈ UNIV. y = pubconst a x"
by auto
have "?T ⊆ {c. Γ (Fun c []) = TAtom a ∧ public c}" by auto
moreover have "∃f::nat ⇒ ex_fun. bij_betw f UNIV ?T"
using bij_betwI'[OF *] by blast
hence "infinite ?T" by (metis nat_not_finite bij_betw_finite)
ultimately show ?thesis using infinite_super by blast
qed
lemma assm10: "TComp f T ⊑ Γ t ⟹ arity f > 0"
proof (induction rule: Γ.induct)
case (1 x)
hence *: "TComp f T ⊑ Γ⇩v x" by simp
hence "Γ⇩v x ≠ TAtom Bot" unfolding Γ⇩v_def by force
hence "∀t ∈ subterms (fst x). case t of
(TComp f T) ⇒ arity f > 0 ∧ arity f = length T
| _ ⇒ True"
unfolding Γ⇩v_def by argo
thus ?case using * unfolding Γ⇩v_def by fastforce
qed auto
lemma assm11: "im.wf⇩t⇩r⇩m (Γ (Var x))"
proof -
have "im.wf⇩t⇩r⇩m (Γ⇩v x)" unfolding Γ⇩v_def im.wf⇩t⇩r⇩m_def by auto
thus ?thesis by simp
qed
lemma assm12: "Γ (Var (τ, n)) = Γ (Var (τ, m))"
apply (cases "∀t ∈ subterms τ. case t of
(TComp f T) ⇒ arity f > 0 ∧ arity f = length T
| _ ⇒ True")
by (auto simp add: Γ⇩v_def)
lemma Ana_const: "arity c = 0 ⟹ Ana (Fun c T) = ([],[])"
by (cases c) simp_all
lemma Ana_keys_subterm: "Ana t = (K,T) ⟹ k ∈ set K ⟹ k ⊏ t"
proof (induct t rule: Ana.induct)
case (1 U)
then obtain m where "U = [Fun pub [k], m]" "K = [k]" "T = [m]"
by (auto elim!: Ana⇩c⇩r⇩y⇩p⇩t.elims Ana⇩s⇩i⇩g⇩n.elims)
thus ?case using Fun_subterm_inside_params[of k crypt U] by auto
qed (auto elim!: Ana⇩c⇩r⇩y⇩p⇩t.elims Ana⇩s⇩i⇩g⇩n.elims)
global_interpretation tm: typed_model' arity public Ana Γ
by (unfold_locales, unfold wf⇩t⇩r⇩m_def[symmetric],
metis assm7, metis assm8, metis assm9, metis assm10, metis assm11, metis assm6,
metis assm12, metis Ana_const, metis Ana_keys_subterm)
subsection ‹TLS example: Proving type-flaw resistance›
abbreviation Γ⇩v_clientHello where
"Γ⇩v_clientHello ≡
TComp clientHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]"
abbreviation Γ⇩v_serverHello where
"Γ⇩v_serverHello ≡
TComp serverHello [TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce, TAtom Nonce]"
abbreviation Γ⇩v_pub where
"Γ⇩v_pub ≡ TComp pub [TAtom PrivKey]"
abbreviation Γ⇩v_x509 where
"Γ⇩v_x509 ≡ TComp x509 [TAtom Agent, Γ⇩v_pub]"
abbreviation Γ⇩v_sign where
"Γ⇩v_sign ≡ TComp sign [TAtom PrivKey, Γ⇩v_x509]"
abbreviation Γ⇩v_serverCert where
"Γ⇩v_serverCert ≡ TComp serverCert [Γ⇩v_sign]"
abbreviation Γ⇩v_pmsForm where
"Γ⇩v_pmsForm ≡ TComp pmsForm [TAtom SymKey]"
abbreviation Γ⇩v_crypt where
"Γ⇩v_crypt ≡ TComp crypt [Γ⇩v_pub, Γ⇩v_pmsForm]"
abbreviation Γ⇩v_clientKeyExchange where
"Γ⇩v_clientKeyExchange ≡
TComp clientKeyExchange [Γ⇩v_crypt]"
abbreviation Γ⇩v_HSMsgs where
"Γ⇩v_HSMsgs ≡ TComp concat [
Γ⇩v_clientHello,
Γ⇩v_serverHello,
Γ⇩v_serverCert,
TAtom PubConst,
Γ⇩v_clientKeyExchange]"
abbreviation "T⇩1 n ≡ Var (TAtom Nonce,n)"
abbreviation "T⇩2 n ≡ Var (TAtom Nonce,n)"
abbreviation "R⇩A n ≡ Var (TAtom Nonce,n)"
abbreviation "R⇩B n ≡ Var (TAtom Nonce,n)"
abbreviation "S n ≡ Var (TAtom Nonce,n)"
abbreviation "Cipher n ≡ Var (TAtom Nonce,n)"
abbreviation "Comp n ≡ Var (TAtom Nonce,n)"
abbreviation "B n ≡ Var (TAtom Agent,n)"
abbreviation "Pr⇩c⇩a n ≡ Var (TAtom PrivKey,n)"
abbreviation "PMS n ≡ Var (TAtom SymKey,n)"
abbreviation "P⇩B n ≡ Var (TComp pub [TAtom PrivKey],n)"
abbreviation "HSMsgs n ≡ Var (Γ⇩v_HSMsgs,n)"
subsubsection ‹Defining the over-approximation set›
abbreviation clientHello⇩t⇩r⇩m where
"clientHello⇩t⇩r⇩m ≡ Fun clientHello [T⇩1 0, R⇩A 1, S 2, Cipher 3, Comp 4]"
abbreviation serverHello⇩t⇩r⇩m where
"serverHello⇩t⇩r⇩m ≡ Fun serverHello [T⇩2 0, R⇩B 1, S 2, Cipher 3, Comp 4]"
abbreviation serverCert⇩t⇩r⇩m where
"serverCert⇩t⇩r⇩m ≡ Fun serverCert [Fun sign [Pr⇩c⇩a 0, Fun x509 [B 1, P⇩B 2]]]"
abbreviation serverHelloDone⇩t⇩r⇩m where
"serverHelloDone⇩t⇩r⇩m ≡ Fun serverHelloDone []"
abbreviation clientKeyExchange⇩t⇩r⇩m where
"clientKeyExchange⇩t⇩r⇩m ≡ Fun clientKeyExchange [Fun crypt [P⇩B 0, Fun pmsForm [PMS 1]]]"
abbreviation changeCipher⇩t⇩r⇩m where
"changeCipher⇩t⇩r⇩m ≡ Fun changeCipher []"
abbreviation finished⇩t⇩r⇩m where
"finished⇩t⇩r⇩m ≡ Fun finished [Fun prfun [
Fun clientFinished [
Fun prfun [Fun master [PMS 0, R⇩A 1, R⇩B 2]],
R⇩A 3, R⇩B 4, Fun hash [HSMsgs 5]
]
]]"
definition M⇩T⇩L⇩S::"ex_term list" where
"M⇩T⇩L⇩S ≡ [
clientHello⇩t⇩r⇩m,
serverHello⇩t⇩r⇩m,
serverCert⇩t⇩r⇩m,
serverHelloDone⇩t⇩r⇩m,
clientKeyExchange⇩t⇩r⇩m,
changeCipher⇩t⇩r⇩m,
finished⇩t⇩r⇩m
]"
subsection ‹Theorem: The TLS handshake protocol is type-flaw resistant›
theorem "tm.tfr⇩s⇩e⇩t (set M⇩T⇩L⇩S)"
by (rule tm.tfr⇩s⇩e⇩t_if_comp_tfr⇩s⇩e⇩t') eval
end